Soru TABLO DÜZENLEME - SATIRDAKİ BAŞLIKLARI SÜTUNA ÇEVİRME

[ThaLees]

Merhabalar
Ekteki gibi bir çok tablom var. Bu tabloda "Info" sayfasındaki bilgileri "Pivot" sayfasındaki gibi alt alta özetlemem gerekiyor. Daha etkili bir rapor ve pivot tablo için.
"Info" sayfasındaki 1 satırdaki başlıkta yazan "2023-M02" ibaresi 2023 yılı ve Şubat Ayı anlamına gelmekte.
Bu tablo gibi birden fazla excelim olduğu için çok zaman alacağından bunu yapmamın kısa bir yolu var mıdır?

 

[Necdet]

Merhaba,
Eksik bilgi mi var? sadece belli bir ay mı listelenecek, yoksa tüm aylar mı?

 

[ThaLees]

Merhabalar
tüm tablo bu şekilde listelenecek maalesef

 

[Necdet]

Merhaba,
Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.

Sub Dene()

Dim arr As Variant
Dim ar  As Variant
Dim i   As Long
Dim j   As Integer
Dim c   As Integer
Dim yil As Integer
Dim ay  As String

Sayfa2.Range("A2:D" & Rows.Count).ClearContents

arr = Sayfa1.Range("A1").CurrentRegion.Value
ar = Sayfa1.Range("A1").Resize(UBound(arr, 1), 4).Value

For c = 2 To UBound(arr, 2)
    yil = CInt(Left(arr(1, c), 4))
    ay = Format(DateValue(Replace(arr(1, c), "M", "")), "mmmm")
    For i = 2 To UBound(arr, 1)
        ar(i, 2) = yil
        ar(i, 3) = ay
        ar(i, 4) = arr(i, c)
    Next i
    j = Sayfa2.Cells(Rows.Count, "A").End(3).Row + 1
   
    Sayfa2.Range("A" & j).Resize(UBound(arr, 1), 4) = ar
    Sayfa2.Rows(j).Delete
Next c

MsgBox "İşlem Tamamdır..."
End Sub

 

[ThaLees]

Merhaba,
Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.

Sub Dene()

Dim arr As Variant
Dim ar  As Variant
Dim i   As Long
Dim j   As Integer
Dim c   As Integer
Dim yil As Integer
Dim ay  As String

Sayfa2.Range("A2:D" & Rows.Count).ClearContents

arr = Sayfa1.Range("A1").CurrentRegion.Value
ar = Sayfa1.Range("A1").Resize(UBound(arr, 1), 4).Value

For c = 2 To UBound(arr, 2)
    yil = CInt(Left(arr(1, c), 4))
    ay = Format(DateValue(Replace(arr(1, c), "M", "")), "mmmm")
    For i = 2 To UBound(arr, 1)
        ar(i, 2) = yil
        ar(i, 3) = ay
        ar(i, 4) = arr(i, c)
    Next i
    j = Sayfa2.Cells(Rows.Count, "A").End(3).Row + 1
  
    Sayfa2.Range("A" & j).Resize(UBound(arr, 1), 4) = ar
    Sayfa2.Rows(j).Delete
Next c

MsgBox "İşlem Tamamdır..."
End Sub

Hocam çok teşekkür ederim. O kadar büyük zahmetten kurtuldum ki anlatamam.

 

[Korhan Ayhan]

Bu da alternatif olsun...

Option Explicit

Sub Transpose_Table()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Integer, Month_Name As Variant
    Dim Rng As Range, Last_Row As Long, Y
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    Set S1 = Sheets("Info")
    Set S2 = Sheets("Pivot")
    Set Rng = S1.Range("A2:A" & S1.Cells(S1.Rows.Count, 1).End(3).Row)
    
    S2.Range("A2:D" & S2.Rows.Count).Clear
    
    Last_Row = 2
    
    For X = 2 To S1.Cells(1, S1.Columns.Count).End(1).Column
        S2.Cells(Last_Row, 1).Resize(Rng.Rows.Count, 1).Value = Rng.Value
        S2.Cells(Last_Row, 4).Resize(Rng.Rows.Count, 1).Value = Rng.Offset(, X - 1).Value
        S2.Cells(Last_Row, 2).Resize(Rng.Rows.Count, 1).Value = S1.Cells(1, X).Value
        Last_Row = S2.Cells(S2.Rows.Count, 1).End(3).Row + 1
    Next

    S2.Range("B2:B" & Last_Row - 1).TextToColumns _
    Destination:=S2.Range("B2"), _
    DataType:=xlFixedWidth, OtherChar:="-", _
    FieldInfo:=Array(Array(0, 1), Array(4, 9), Array(6, 1)), _
    TrailingMinusNumbers:=True
    
    X = 1
    
    For Each Month_Name In Application.GetCustomListContents(4)
        S2.Columns(3).Replace What:=X, Replacement:=Month_Name, LookAt:=xlWhole
        X = X + 1
    Next
    
    S2.Range("D2:D" & Last_Row - 1).NumberFormat = "#,##0"
    S2.Columns.AutoFit

    Set Rng = Nothing
    Set S1 = Nothing
    Set S2 = Nothing

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With

    MsgBox "Veriler düzenli tablo biçimine dönüştürülmüştür.", vbInformation
End Sub