Yatay satırlardaki verileri sütunlara aktarmak

[kayburcak]

Merhaba

Arkadaşlar konuyla ilgili örnekleri inceledim.Ancak bunu yapamadım.Örnek ektedir
Yardımcı olursanız sevinirim.
1.Sayfadaki verileri dikey olarak 2.sayfaya taşımak istiyorum.

 

[Ömer]

Merhaba,

Sayfa1 de 6. satır ile 9. satır arasına neden 2. bir başlık satırı koydunuz.

 

[kayburcak]

teşekkür ederim
6.satırdaki ikinci başlığı dikkate almayabiliriz

 

[Ömer]

Module kopyalayıp çalıştırın.
Verileri Sayfa3 de istediğiniz düzene göre listeleyecektir. Eğer yanlış aktarım varsa, olması gerekenle birlikte yanlış olan bölümleri hücre adreside vererek açıklayınız.

Sub Duzenle()
 
    Dim S1 As Worksheet, S3 As Worksheet, son As Byte, k As Integer, i As Long
    Dim sat As Long, sut As Integer, j As Integer, art As Byte, ilk As Long
 
 
    Set S1 = Sheets("Sayfa1")
    Set S3 = Sheets("Sayfa3")
 
    Application.ScreenUpdating = False
    S3.Cells.Clear
 
    son = Day(DateSerial(Year(S1.Range("C1")), Month(S1.Range("C1")) + 1, 0))
 
    S3.Range("A2") = Format(S1.Range("C1"), "mmmm yyyy")
 
    k = 3
    For i = 3 To S1.Cells(Rows.Count, "B").End(xlUp).Row
 
        sat = 4: sut = 3
        If S1.Cells(i, "B") <> "" Then
 
            S3.Cells(1, k) = Format(S1.Cells(1, sut), "mmmm yyyy")
 
            With S3.Range(S3.Cells(1, k), S3.Cells(1, k + 2))
                .Merge
                .HorizontalAlignment = xlCenter
            End With
 
            With S3.Range(S3.Cells(2, k), S3.Cells(2, k + 2))
                .Merge
                .HorizontalAlignment = xlCenter
            End With
 
            With S3.Range(S3.Cells(1, k), S3.Cells(3, k + 2))
                .Borders(xlEdgeLeft).Weight = xlThick
                .Borders(xlEdgeTop).Weight = xlThick
            End With
 
 
            S3.Cells(2, k) = S1.Cells(i, "B")
            S3.Cells(3, k) = "ALIŞ"
            S3.Cells(3, k + 1) = "DAĞIT"
            S3.Cells(3, k + 2) = "İADE"
 
            For j = 1 To son
                If Weekday(S1.Cells(1, sut)) = 1 Then
                    art = 2
                    S3.Cells(sat + 1, "A") = "Toplam"
                    S3.Range(S3.Cells(sat, "A"), S3.Cells(sat, "B")).Font.ColorIndex = 3
                Else
                    art = 1
                End If
                If S3.Cells(sat, "A") = "" Then
                    S3.Cells(sat, "A") = Format(S1.Cells(1, sut), "dddd")
                    S3.Cells(sat, "B") = Day(S1.Cells(1, sut))
                    If S3.Cells(sat - 1, "B") = "" Then
                        ilk = sat
                    Else
                        ilk = S3.Cells(sat, "B").End(xlUp).Row
                    End If
                    If art = 2 Then
                        S3.Range(S3.Cells(sat + 1, "C"), S3.Cells(sat + 1, son + 3)) = _
                            "=Sum(" & S3.Range("C" & ilk & ":C" & sat).Address(0, 0) & ")"
                        S3.Range(S3.Cells(sat + 1, "A"), S3.Cells(sat + 1, son + 3)).Font.Bold = True
                    End If
                End If
                S3.Cells(sat, k) = S1.Cells(i, sut)
                S3.Cells(sat, k + 1) = S1.Cells(i, sut)
                S3.Cells(sat, k + 2) = S1.Cells(i, sut + 1)
                S3.Cells(sat, k + 2).Font.ColorIndex = 3
                sat = sat + art: sut = sut + 3
            Next j
            k = k + 3
 
        End If
 
    Next i
    If S3.Cells(sat - 1, "A") <> "Toplam" Then
        S3.Cells(sat, "A") = "Toplam"
        S3.Range(S3.Cells(sat, "C"), S3.Cells(sat, son + 3)) = _
                        "=Sum(" & S3.Range("C" & ilk & ":C" & sat - 1).Address(0, 0) & ")"
        S3.Range(S3.Cells(sat, "A"), S3.Cells(sat, son + 3)).Font.Bold = True
    End If
 
    S3.Cells.EntireColumn.AutoFit
 
End Sub

.

 

[kayburcak]

Üstad ellerine sağlık.tam istediğimiz gibi olmuş.Beni satır satır kopyalamaktan
kurtardın.