Excel VBA ile Sütun Satır Çevrilmesi (Unpivot)

k1, k2, k3, ssc_kaynak_1, ssc_kaynak_2, ssc_kaynak_3, ssc_kaynak_4, ssc_hedef_1,ssc_hedef_2

Kolonlarına sahip bir excel dosyasını

k1, k2, k3, ssc_kaynak, ssc_hedef

kolonlarına sahip hale getirmek için aşağıdaki VBA (Visual Basic Applications) Script kullanılabilir. Buradaki amaç ssc_kaynak kolonları için 4 kolonu 4 satıra, ssc_hedef kolonları için 2 kolonu 2 satıra, toplam 4+2=6 kolonu 4*2=8 satıra çevirmek.

Örneğin:

veri_k1,veri_k2, veri_k3, veri_ssc_kaynak_1, veri_ssc_kaynak_2, veri_ssc_kaynak_3, veri_ssc_kaynak_4, veri_ssc_hedef_1, veri_ssc_hedef_2

halinden aşağıdaki hale çevirmek

veri_k1, veri_k2, veri_k3, veri_ssc_kaynak_1, veri_ssc_hedef_1
veri_k1, veri_k2, veri_k3, veri_ssc_kaynak_1, veri_ssc_hedef_2
veri_k1, veri_k2, veri_k3, veri_ssc_kaynak_2, veri_ssc_hedef_1
veri_k1, veri_k2, veri_k3, veri_ssc_kaynak_2, veri_ssc_hedef_2
veri_k1, veri_k2, veri_k3, veri_ssc_kaynak_3, veri_ssc_hedef_1
veri_k1, veri_k2, veri_k3, veri_ssc_kaynak_3, veri_ssc_hedef_2
veri_k1, veri_k2, veri_k3, veri_ssc_kaynak_4, veri_ssc_hedef_1
veri_k1, veri_k2, veri_k3, veri_ssc_kaynak_4, veri_ssc_hedef_2

excel_vba_unpivot.xlsm.zip


Option Explicit
Dim sourceWorksheet As Excel.Worksheet
Dim targetWorksheet As Excel.Worksheet
Dim sourceWorksheetRowCount As Integer
Dim targetWorksheetI As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer

Sub Unpivot()

    Set sourceWorksheet = ThisWorkbook.Worksheets("normal")
    Set targetWorksheet = ThisWorkbook.Worksheets("unpivot")
    targetWorksheet.Unprotect

    targetWorksheet.Cells(1, 1).Value = sourceWorksheet.Cells(1, 1).Value
    targetWorksheet.Cells(1, 2).Value = sourceWorksheet.Cells(1, 2).Value
    targetWorksheet.Cells(1, 3).Value = sourceWorksheet.Cells(1, 3).Value
    targetWorksheet.Cells(1, 4).Value = sourceWorksheet.Cells(1, 4).Value
    targetWorksheet.Cells(1, 5).Value = sourceWorksheet.Cells(1, 8).Value

    sourceWorksheetRowCount = sourceWorksheet.UsedRange.Rows.Count
    targetWorksheetI = 2

    For i = 2 To sourceWorksheetRowCount
        For j = 4 To 7
            For k = 8 To 9
                If (IsNull(sourceWorksheet.Cells(i, j)) = False And Trim(sourceWorksheet.Cells(i, j).Value) <> "" And IsNull(sourceWorksheet.Cells(i, k)) = False And Trim(sourceWorksheet.Cells(i, k).Value) <> "") Then
                    targetWorksheet.Cells(targetWorksheetI, 1) = sourceWorksheet.Cells(i, 1)
                    targetWorksheet.Cells(targetWorksheetI, 2) = sourceWorksheet.Cells(i, 2)
                    targetWorksheet.Cells(targetWorksheetI, 3) = sourceWorksheet.Cells(i, 3)
                    targetWorksheet.Cells(targetWorksheetI, 4) = sourceWorksheet.Cells(i, j)
                    targetWorksheet.Cells(targetWorksheetI, 5) = sourceWorksheet.Cells(i, k)
                    targetWorksheetI = targetWorksheetI + 1
                End If
            Next k
        Next j
    Next i

End Sub

Bir cevap yazın

E-posta hesabınız yayımlanmayacak. Gerekli alanlar * ile işaretlenmişlerdir