Listeleme Hk.

[nongeyikm]

Merhaba,

Ekli dosyada, PC-YAZICI-MONİTÖR VS dosyasında yüzlerce veri var. Örnekte verdiğim şekilde 4 sutun olarak etiket sayfasındaki düzene göre ve seri no lar alt satırda olacak şekilde bunları listelemek istiyorum.

Desteğinizi rica ederim.

 

[askm]

Aşağıdaki kodları deneyin.

Sub askm()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets(1)
Set s2 = Sheets(2)
Dim son As Long, satir As Long
Dim sutun As Byte
son = s2.Range("B" & Rows.Count).End(3).Row
Application.ScreenUpdating = False
s1.Cells.Clear
satir = 2
sutun = 1
For i = 2 To son
    s1.Cells(satir, sutun) = s2.Cells(i, "B") & vbLf & s2.Cells(i, "I")
    With s1.Cells(satir, sutun)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Font.Bold = True
    End With
    If sutun = 4 Then
        sutun = 1
        satir = satir + 1
    Else
        sutun = sutun + 1
    End If
Next i

Application.ScreenUpdating = True
MsgBox "İşlem tamam", vbInformation, "UYARI!"
End Sub

 

[Mdemir63]

Selamlar
Sayın: @askm hocam göndermiş
bu da alternatif olsun
deneyiniz

 

[nongeyikm]

Elinize sağlık. Çok teşekkür ederim.

 

[Mdemir63]

Rica ederim.
İyi çalışmalar

 

[nongeyikm]

Sn. askm

Aşağıdaki kod yaptığınız çalışma içinde yer alıyor. Bu kod hücre içindeki 1. ve 2. satırları farklı fonta çeviriyor. Aynı hücre içinde 3. bir satırı da fontlamak için koda ekleme yapabilir misiniz.


Option Explicit

Sub Font_Ayarla()
Dim s1 As Worksheet, Veri As Variant, X As Long, son As Long, Alan As Range

Set s1 = Sheets("Etiket")

son = s1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

For Each Alan In s1.Range("A1" & son)
If Alan <> "" Then
Alan.Value = Alan.Value
Alan.Replace " ", Chr(10)
Alan.Font.Size = 12
Alan.Font.Bold = True
Alan.Font.Name = "Calibri"
Veri = Split(Alan.Value, Chr(10))
Alan.Characters(Len(Veri(0)) + 1, Len(Veri(1)) + 1).Font.Size = 8
End If
Next

MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub