Transpose işlemi

[search77]

Merhaba Saygıdeğer Arkadaşlar,
Ekli dosyamda bir tablom var onu macro ile transpose yapmak istiyorum.
Dosyada gerekli açıklamayı yaptım.
Yardımcı olabileceklere şimdiden minnettarım.
Saygılar.

 

[search77]

Yardım edebilecek arkadaşlar var mı acaba?
Teşekkürler.

 

[veyselemre]

Sub adoTranspose()
    Dim adoCn As Object, rs As Object
    Dim sonA&, strSql$, i&

    Range("G:Z").Clear

    Set adoCn = CreateObject("ADODB.Connection")
    adoCn.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCn.Properties("Data Source") = ThisWorkbook.FullName
    adoCn.Properties("Extended Properties") = "Excel 12.0; HDR=YES"
    adoCn.Open

    Set rs = CreateObject("Adodb.RecordSet")

    sonA = Cells(Rows.Count, 1).End(3).Row

    strSql = "TRANSFORM FIRST(CEVAP) SELECT ID FROM [Sheet1$A1:C" & sonA & "] " & _
             "GROUP BY ID ORDER BY SORU ASC PIVOT SORU"

    rs.Open strSql, adoCn
    
    For i = 0 To rs.Fields.Count - 1
        With Cells(1, i + 7)
            .Clear
            .Value = rs.Fields(i).Name
            .Font.Bold = True
            .Font.Color = vbWhite
            .Interior.Color = vbBlack
            .HorizontalAlignment = xlCenter
        End With
    Next
    
    [G2].CopyFromRecordset rs

    Columns.AutoFit
    rs.Close
    adoCn.Close
    
    Set rs = Nothing
    Set adoCn = Nothing
    
End Sub

 

[search77]

Sayın veysel bey öncelikle elinize kolunuza sağlık

Fakat 130 binlik bir datayı çalıştırmak istediğimde hata alıyorum, rs.Open strSql, adoCn bukısıma takıyor.

Yardımcı olabilir misiniz.

 

[veyselemre]

Ado 65536 satır ve 255 sütunda çalışır.

 

[YUSUF44]

Ado 65536 satır ve 255 sütunda çalışır.

Bunu ben de bilmiyordum. Son zamanlarda sıkça kullandığım bir özellikti. Bu gibi durumlarda ne yapılması gerekiyor acaba?

 

[veyselemre]

strSql = "TRANSFORM FIRST(CEVAP) SELECT ID FROM [Sheet1$A:C] " & _
"GROUP BY ID ORDER BY SORU ASC PIVOT SORU"

Şeklinde satır sınırlaması aşılıyor ama 255 sütun sınırlaması aşılamıyor.

Sub adoTranspose()
    Dim adoCn As Object, rs As Object
    Dim strSql$, i&

    Range("G:Z").Clear

    Set adoCn = CreateObject("ADODB.Connection")
    adoCn.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCn.Properties("Data Source") = ThisWorkbook.FullName
    adoCn.Properties("Extended Properties") = "Excel 12.0; HDR=YES"
    adoCn.Open

    Set rs = CreateObject("Adodb.RecordSet")

    strSql = "TRANSFORM FIRST(CEVAP) SELECT ID FROM [Sheet1$A:C] " & _
             "GROUP BY ID ORDER BY SORU ASC PIVOT SORU"

    rs.Open strSql, adoCn
    
    For i = 0 To rs.Fields.Count - 1
        With Cells(1, i + 7)
            .Clear
            .Value = rs.Fields(i).Name
            .Font.Bold = True
            .Font.Color = vbWhite
            .Interior.Color = vbBlack
            .HorizontalAlignment = xlCenter
        End With
    Next
    
    [G2].CopyFromRecordset rs

    Columns.AutoFit
    rs.Close
    adoCn.Close
    
    Set rs = Nothing
    Set adoCn = Nothing
    
End Sub

 

[search77]

Aslında sütun yeterli benim için ama 65 bin aşılmalı

Bu yazdığınız son kod da da 65 bin aşılamıyor malesef tekrar kontrol edebilir misiniz

Teşekkürler.

 

[veyselemre]

Yukarıdaki kod çalışıyor ama yine sorgu sonucunda 65536 satırdan fazlasında işlem yapmıyor. 2 ye bölünerek yapılabilir. Yada başka kod yazmak gerekir. Aslında bu iş için en güzel çözüm power query ama bende power query bir süredir çalışmıyor, ne yaptıysam çalıştıramadım.

 

[veyselemre]

Sub transpose()

    Application.ScreenUpdating = False
    Dim sonSat&, sonSut&, i&
    Dim dicSut As Object, dicSat As Object
    Set dicSut = CreateObject("Scripting.Dictionary")
    Set dicSat = CreateObject("Scripting.Dictionary")

    [G:XFD].Clear
    [B:B].Copy [G1]
    [G:G].RemoveDuplicates Columns:=1, Header:=xlYes
    sonSut = Cells(Rows.Count, "G").End(3).Row
    Range("$G1:$G" & sonSut).Sort [G1], xlAscending, , , , , , xlYes
    Range("$G2:$G" & sonSut).Copy

    For i = 2 To sonSut
        dicSut(Cells(i, "G").Value) = i + 6
    Next i

    [H1].PasteSpecial transpose:=True
    [G:G].Clear
    [A:A].Copy [G1]
    [G:G].RemoveDuplicates Columns:=1, Header:=xlYes
    sonSat = Cells(Rows.Count, "G").End(3).Row
    Range("$G1:$G" & sonSat).Sort [G1], xlAscending, , , , , , xlYes
    For i = 2 To sonSat
        dicSat(Cells(i, "G").Value) = i
    Next i

    sonSat = Cells(Rows.Count, "A").End(3).Row
    For i = 2 To sonSat
        Cells(dicSat(Cells(i, 1).Value), dicSut(Cells(i, 2).Value)).Value = Cells(i, 3).Value
    Next i
    Application.ScreenUpdating = True

End Sub

 

[search77]

Veysel bey son yazdığın kod ile çalıştı,

Elinize kolunuza emeğinize sağlık, çok çok teşekkürler.