sütundaki verileri satıra aktarma

[uygarakgul]

İsteğinizi karşılar mı bilmiyorum? Forumdan bazı örnekleri kullanarak bir şeyler yaptım.
[/ALINTI]

Emeğinize sağlık gayet sağlıklı çalışıyor, çok teşekkür ederim. İyi günler diler saygılar sunarım.

 

[aerten]

Kolay gelsin. İyi günler.

 

[uygarakgul]

Aşağıdaki makroyu dener misiniz?

Sub yemekler()
Set s1 = Sheets("Sayfa1")
oğul = s1.Hücreler(Satırlar.Sayı, "A").Bitiş(3).Satır
eski = s1.Hücreler(Satırlar.Sayı, "I").End(3).Satır
Eskiyse> 1 O zaman
    s1.Range("I2:XFD" & eski).ClearContents
Bitir

Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;veri kaynağı=" & _
ThisWorkbook.FullName & ";genişletilmiş özellikler=""Excel 12.0;hdr=yes"""

sorgu = "[YEMEK ADI]'nin boş olmadığı [Sayfa1$A1:F" & son & "] arasından farklı [YEMEK ADI] seçin"
Set rs = con.Execute(sorgu)

s1.[I2].CopyFromRecordset rs
yeni = s1.Hücreler(Satırlar.Sayı, "I").Bitiş(3).Satır
   
i = 2 için oğul
    sat = WorksheetFunction.Match(s1.Cells(i, "A")), s1.Range("I1:I" & yeni), 0)
    sut = s1.Cells(sat, Columns.Count).End(xlToLeft).Column + 1
    s1.Hücreler(sat, eş) = s1.Hücreler(i, "D")
    s1.Hücreler(sat, toplam + 1) = s1.Hücreler(i, "E")
    s1.Hücreler(sat, çift + 2) = s1.Hücreler(i, "F")
Sonraki
Aboneliği Bitir

[/ALINTI]
Emeğinize, ilginize sağlık gayet sağlıklı çalışıyor, çok teşekkür ederim. İyi günler diler saygılar sunarım.

 

[YUSUF44]

Bi hatırlatma yapayım:

Makronun tam sağlıklı çalışması için D, E ve F sütunlarının mutlaka dolu olması gerekmektedir. Herhangi biri boş olursa raporda sütun kayması olur.

Buna engel olmak için For Next kısmını aşağıdaki gibi değiştirebilirsiniz:

For i = 2 To son
    sat = WorksheetFunction.Match(s1.Cells(i, "A"), s1.Range("I1:I" & yeni), 0)
    sut = s1.Cells(sat, Columns.Count).End(xlToLeft).Column + 1
    If s1.Cells(i, "D") = "" Then
        s1.Cells(sat, sut) = "(Boş)"
    Else
        s1.Cells(sat, sut) = s1.Cells(i, "D")
    End If
    If s1.Cells(i, "E") = "" Then
        s1.Cells(sat, sut + 1) = "(Boş)"
    Else
        s1.Cells(sat, sut + 1) = s1.Cells(i, "E")
    End If
    If s1.Cells(i, "F") = "" Then
        s1.Cells(sat, sut + 2) = "(Boş)"
    Else
        s1.Cells(sat, sut + 2) = s1.Cells(i, "F")
    End If
Next