Merubah data horizontal menjadi vertikal

  1. 7 bulan yang lalu

    Assalamu'alaikum...
    mohon bantuannya..saya ingin merubah data dalam bentuk horizontal menjadi vertikal dalam satu kolom dengan kode tertentu

    @fredi ...

    Pertama, pada contoh script yang saya berikan, temukan baris script berikut :

    ...
    For lZ = 1 To UBound(xDataRow, 1)
        lCol = (lMaxC * (lY - 1) + 1) + (lX - 1)
        Sheet3.Cells(lRow, "B").Value2 = lRow - 4
        Sheet3.Cells(lRow, "C").Value2 = UCase$(xDataRow(lZ, 1))
        Sheet3.Cells(lRow, "D").Value2 = UCase$(sCode)
        Sheet3.Cells(lRow, "E").Value2 = xDataVal(lZ, lCol)
        lRow = lRow + 1
    Next
    ...

    [1]. Kemudian, jika yang mas maksud adalah jika ada baris kosong pada kolom B (range B8:B17) seperti gambar berikut,

    [attachment:5de48589e4b55]

    maka ubah baris script di atas dengan menambahkan blok IF seperti berikut ini :

    ...
    For lZ = 1 To UBound(xDataRow, 1)
        '+-- Tambahkan kondisional ini.
        If Len(xDataRow(lZ, 1)) Then
            lCol = (lMaxC * (lY - 1) + 1) + (lX - 1)
            Sheet3.Cells(lRow, "B").Value2 = lRow - 4
            Sheet3.Cells(lRow, "C").Value2 = UCase$(xDataRow(lZ, 1))
            Sheet3.Cells(lRow, "D").Value2 = UCase$(sCode)
            Sheet3.Cells(lRow, "E").Value2 = xDataVal(lZ, lCol)
            lRow = lRow + 1
        End If
    Next
    ...

    [2]. Atau, kalau yang dimaksud adalah ada baris data (nilai) yang kosong pada range C8:Q17 seperti gambar berikut,

    [attachment:5de4875f5bfcd]

    maka ubah baris script di atas dengan menambahkan blok IF menjadi seperti berikut ini :

    ...
    For lZ = 1 To UBound(xDataRow, 1)
        '+-- Tambahkan kondisional ini.
        If Len(xDataVal(lZ, lCol)) Then
            lCol = (lMaxC * (lY - 1) + 1) + (lX - 1)
            Sheet3.Cells(lRow, "B").Value2 = lRow - 4
            Sheet3.Cells(lRow, "C").Value2 = UCase$(xDataRow(lZ, 1))
            Sheet3.Cells(lRow, "D").Value2 = UCase$(sCode)
            Sheet3.Cells(lRow, "E").Value2 = xDataVal(lZ, lCol)
            lRow = lRow + 1
        End If
    Next
    ...

    [3]. Atau, jika kondisi yang akan dihindari adalah seperti poin 1 dan poin 2 di atas, maka tambahkan saja bolk IF seperti berikut ini :

    ...
    For lZ = 1 To UBound(xDataRow, 1)
        '+-- Tambahkan kondisional ini.
        If Len(xDataRow(lZ, 1)) Then
            If Len(xDataVal(lZ, lCol)) Then
                lCol = (lMaxC * (lY - 1) + 1) + (lX - 1)
                Sheet3.Cells(lRow, "B").Value2 = lRow - 4
                Sheet3.Cells(lRow, "C").Value2 = UCase$(xDataRow(lZ, 1))
                Sheet3.Cells(lRow, "D").Value2 = UCase$(sCode)
                Sheet3.Cells(lRow, "E").Value2 = xDataVal(lZ, lCol)
                lRow = lRow + 1
            End If
        End If
    Next
    ...

    Demikian.

  2. Caton

    30 Nov 2019 Terverifikasi Indonesia + 16.046 Poin

    @fredi ...

    Klo pake formula, ribet... :) Saya ganti pake macro VBA saja ya. Filenya terlampir. Semoga sesuai...

    Demikian.

  3. Terimakasih mas @Caton atas jawabannya, namun bolehkan saya bertanya lagi ....? saat saya merubah data baris, pada baris yang kosong ikut dalam data hasil... adakah cara agar data yang nantinya diinputkan dalam sheet hasil hanya data yang isi saja... masalahnya nantinya datanya berubah-ubah...

  4. Caton

    2 Des 2019 Terverifikasi Jawaban Terpilih Indonesia + 16.046 Poin

    @fredi ...

    Pertama, pada contoh script yang saya berikan, temukan baris script berikut :

    ...
    For lZ = 1 To UBound(xDataRow, 1)
        lCol = (lMaxC * (lY - 1) + 1) + (lX - 1)
        Sheet3.Cells(lRow, "B").Value2 = lRow - 4
        Sheet3.Cells(lRow, "C").Value2 = UCase$(xDataRow(lZ, 1))
        Sheet3.Cells(lRow, "D").Value2 = UCase$(sCode)
        Sheet3.Cells(lRow, "E").Value2 = xDataVal(lZ, lCol)
        lRow = lRow + 1
    Next
    ...

    [1]. Kemudian, jika yang mas maksud adalah jika ada baris kosong pada kolom B (range B8:B17) seperti gambar berikut,

    baris-kosong.png

    maka ubah baris script di atas dengan menambahkan blok IF seperti berikut ini :

    ...
    For lZ = 1 To UBound(xDataRow, 1)
        '+-- Tambahkan kondisional ini.
        If Len(xDataRow(lZ, 1)) Then
            lCol = (lMaxC * (lY - 1) + 1) + (lX - 1)
            Sheet3.Cells(lRow, "B").Value2 = lRow - 4
            Sheet3.Cells(lRow, "C").Value2 = UCase$(xDataRow(lZ, 1))
            Sheet3.Cells(lRow, "D").Value2 = UCase$(sCode)
            Sheet3.Cells(lRow, "E").Value2 = xDataVal(lZ, lCol)
            lRow = lRow + 1
        End If
    Next
    ...

    [2]. Atau, kalau yang dimaksud adalah ada baris data (nilai) yang kosong pada range C8:Q17 seperti gambar berikut,

    baris-kosong2.png

    maka ubah baris script di atas dengan menambahkan blok IF menjadi seperti berikut ini :

    ...
    For lZ = 1 To UBound(xDataRow, 1)
        '+-- Tambahkan kondisional ini.
        If Len(xDataVal(lZ, lCol)) Then
            lCol = (lMaxC * (lY - 1) + 1) + (lX - 1)
            Sheet3.Cells(lRow, "B").Value2 = lRow - 4
            Sheet3.Cells(lRow, "C").Value2 = UCase$(xDataRow(lZ, 1))
            Sheet3.Cells(lRow, "D").Value2 = UCase$(sCode)
            Sheet3.Cells(lRow, "E").Value2 = xDataVal(lZ, lCol)
            lRow = lRow + 1
        End If
    Next
    ...

    [3]. Atau, jika kondisi yang akan dihindari adalah seperti poin 1 dan poin 2 di atas, maka tambahkan saja bolk IF seperti berikut ini :

    ...
    For lZ = 1 To UBound(xDataRow, 1)
        '+-- Tambahkan kondisional ini.
        If Len(xDataRow(lZ, 1)) Then
            If Len(xDataVal(lZ, lCol)) Then
                lCol = (lMaxC * (lY - 1) + 1) + (lX - 1)
                Sheet3.Cells(lRow, "B").Value2 = lRow - 4
                Sheet3.Cells(lRow, "C").Value2 = UCase$(xDataRow(lZ, 1))
                Sheet3.Cells(lRow, "D").Value2 = UCase$(sCode)
                Sheet3.Cells(lRow, "E").Value2 = xDataVal(lZ, lCol)
                lRow = lRow + 1
            End If
        End If
    Next
    ...

    Demikian.

  5. Oke Mas @Caton terimakasih atas jawaban dan waktuya... semoga sehat selalu...

  6. Mas @Caton saya sudah mencoba memasukan script ini

  7. pada sheet hasil muncul eror, yaitu ada 2 kode yang salah (apakah efek dari kode jeruk yang belum terisi?)
    sedangkan data yang dimaksud kosong adalah sebagai berikut.. mohon bantuannya

  8. Caton

    3 Des 2019 Terverifikasi Indonesia + 16.046 Poin

    @fredi ...

    Untuk nama range dbData.Baris dan dbData.Nilai, rujukannya sudah benar belum mas? Saya coba (setelah rujukan nama range yang digunakan saya atur ulang), hasilnya sesuai... Coba periksa dahulu rujukan nama rangenya, atau lampirkan saja filenya.

    Demikian.

  9. Oh iya ini mas @Caton

  10. Caton

    3 Des 2019 Terverifikasi Indonesia + 16.046 Poin
    Di sunting 7 bulan yang lalu oleh Caton

    @fredi ...

    Script hasil modifikasi yang mas buat seperti berikut :

    ...
    lRow = 5
    Sheet3.Range("B5:E204").ClearContents
    For lX = 1 To lMaxC
        sPrefix = vbNullString
        sSuffix = vbNullString
        For lY = 1 To lMaxB
            lCol = lMaxC * (lY - 1) + 1
            If xDataCol(1, lCol) <> vbNullString Then
                sPrefix = UCase$(Left$(xDataCol(1, lCol), 1))
            End If
            If xDataCol(3, lCol + lX - 1) <> vbNullString Then
                sSuffix = Trim$(xDataCol(3, lCol + lX - 1))
                sCode = sPrefix & sSuffix
            End If
            For lZ = 1 To UBound(xDataRow, 1)
                If Len(xDataVal(lZ, lCol)) Then
                    lCol = (lMaxC * (lY - 1) + 1) + (lX - 1)
                    Sheet3.Cells(lRow, "B").Value2 = lRow - 4
                    Sheet3.Cells(lRow, "C").Value2 = UCase$(xDataRow(lZ, 1))
                    Sheet3.Cells(lRow, "D").Value2 = UCase$(sCode)
                    Sheet3.Cells(lRow, "E").Value2 = xDataVal(lZ, lCol)
                    lRow = lRow + 1
                End If
            Next
        Next
    Next
    ...

    Masalahnya, pada script modifikasi yang mas buat, mas menempatkan blok IF berikut :

    ...
    If xDataCol(3, lCol + lX - 1) <> vbNullString Then
        sSuffix = Trim$(xDataCol(3, lCol + lX - 1))
        sCode = sPrefix & sSuffix
    End If
    ...

    sebagai blok IF sendiri. Padahal, script yang saya susun pada lampiran file saya di atas blok IF tersebut merupakan induk untuk blok FOR ... NEXT berikutnya :

    ...
    If xDataCol(3, lCol + lX - 1) <> vbNullString Then
        sSuffix = Trim$(xDataCol(3, lCol + lX - 1))
        sCode = sPrefix & sSuffix
        For lZ = 1 To UBound(xDataRow, 1)
            lCol = (lMaxC * (lY - 1) + 1) + (lX - 1)
            Sheet3.Cells(lRow, "B").Value2 = lRow - 4
            Sheet3.Cells(lRow, "C").Value2 = UCase$(xDataRow(lZ, 1))
            Sheet3.Cells(lRow, "D").Value2 = UCase$(sCode)
            Sheet3.Cells(lRow, "E").Value2 = xDataVal(lZ, lCol)
            lRow = lRow + 1
        Next
    End If
    ...

    Jadi, seharusnya modifikasi scriptnya tersusun seperti berikut ini :

    ...
    If xDataCol(3, lCol + lX - 1) <> vbNullString Then
        sSuffix = Trim$(xDataCol(3, lCol + lX - 1))
        sCode = sPrefix & sSuffix
        '+-- Masukkan blok FOR ini di dalam blok IF di atas.
        For lZ = 1 To UBound(xDataRow, 1)
            If Len(xDataVal(lZ, lCol)) Then
                lCol = (lMaxC * (lY - 1) + 1) + (lX - 1)
                Sheet3.Cells(lRow, "B").Value2 = lRow - 4
                Sheet3.Cells(lRow, "C").Value2 = UCase$(xDataRow(lZ, 1))
                Sheet3.Cells(lRow, "D").Value2 = UCase$(sCode)
                Sheet3.Cells(lRow, "E").Value2 = xDataVal(lZ, lCol)
                lRow = lRow + 1
            End If
        Next
    End If
    ...

    Saat ini, itu masalah yang saya temukan. Terlampir revisinya.

    Demikian.

  11. Oh iya mass... terimakasih mas@Caton

  12. Mas @Caton bolehkah saya tanya lagi, setelah saya mengacak kode pada data kolom ... pada shet hasil vba tidak urut.... padahal yang saya harapkan data kolom itu A1,A2, dst menjadi kode urut setalah kode Nama Buah...

  13. Caton

    7 Des 2019 Terverifikasi Indonesia + 16.046 Poin

    @fredi ...

    Contoh terlampir (periksa prosedur Sub FillDataTable). Semoga sesuai...

    Demikian.

  14. Wow terimakasih mas@Caton tapi apakah saya boleh bertanya maksud dari script 1X,1Y, 1Z, MAK A, MAX B, MAX C

  15. Caton

    9 Des 2019 Terverifikasi Indonesia + 16.046 Poin

    @fredi ...

    Tujuan dari masing-masing variabel adalah :

    lMaxA = Jumlah kolom data ( kolom C s.d. kolom Q ) = 15
    lMaxB = Jumlah variabel pada nama range C5:Q5 ( Mangga, Jeruk, Semangka ) = 3
    lMaxC = Jumlah maksimum data per kelompok data ( lMaxA / lMaxB ) = 5
    
    lX = Variabel iterasi per kelompok data ( 1 s.d. lMaxC )
    lY = Variabel iterasi sebanyak jumlah kolom data ( 1 s.d. lMaxA )
    lZ = Variabel iterasi sebanyak jumlah baris data ( 1 s.d. UBound(xDataRow, 1) )

    Variabel lX akan menghasilkan nilai 1 s.d. 5 ( 5 merupakan nilai pada variabel lMaxC ) yang digunakan untuk membentuk sufiks dari data yang akan diperiksa :

    A1, A2, A3 ... A5

    Setiap sufiks yang dihasilkan oleh iterasi tersebut, kemudian diperiksa apakah ada pada kolom data range C7:Q7. Iterasi dilakukan sebanyak jumlah kolom yakni dari 1.s.d. 15 ( 15 merupakan nilai pada variabel lMaxA ). Oleh karena nama kelompok data hanya ada pada sel pertama dari setiap kelompok ( Mangga = C5, Jeruk = H5, Semangka = M5), maka pada saat iterasi kedua ( yakni iterasi pada variabel lY ) ini, apabila ada nama kelompok data, dibuat menjadi prefiks.

    Pada iterasi kedua ini, setiap sel data pada range C7:Q7 akan dibandingkan dengan sufiks yang sudah dibuat. Apabila nilai di setiap sel tersebut sama dengan sufiks, maka buat kodenya :

    sCode = sPrefix & sSuffix

    Misalkan, nama kelompok MANGGA dan sufiksnya A1, maka kodenya menjadi MA1. Kemudian lakukan iterasi sebanyak baris data untuk setiap kode tersebut ( yakni iterasi pada variabel lZ ). Pada iterasi ketiga ini, nilai yang akan dituliskan ke tabel akhir hanyalah jika sel pada baris dan kolom terkait ada nilainya saja.

    Selanjutnya, iterasi akan kembali ke iterasi kedua yang akan mencari apakah ada lagi data pada range C7:Q7 yang sama dengan sufiks yang dicari. Jika tidak ada, maka proses akan kembali ke iterasi pertama untuk membuat sufiks selanjutnya dan seterusnya...

    Demikian.

  16. Berarti ketika saya memasukan kode A6, A9 atau bahkan A 12 fungsi ini jadi tidak berfungsi ya mas@Caton karena maksimalnya 5?

    Jadi permasalahannya seperti ini, ya semua itu bisa diatasi dengan membuat kolom mutlak( misalnya dari beberapa data.. maksimal 12 kode.. jadi saya bisa membuat datakolom pertama menjadi 36 kolom (12x3) jadi jika ada kode yang kurang 12 bisa tetampung)

    tetapi maaf mas @Caton saya ingin belajar jadi tanya terus hehehe... semoga mas @Caton berkenan...misal kita membuat jumlah kolom yang tidak mutlak (pada contoh file revisi , tidak mesti kode terakhir itu 5, bisa saja kodenya A3, A6, A7, A10, A12, Meskupin jumlah kolomnya hanya 5) kira-kira script yang perlu dirubah bagian mana ya mas@Caton

  17. Caton

    11 Des 2019 Terverifikasi Indonesia + 16.046 Poin
    Di sunting 7 bulan yang lalu oleh Caton

    @fredi ...

    Saya asumsikan saja bentuk tabelnya tidak tetap. Jumlah kolom per kelompok bisa berbeda. Item sufiksnya juga saya asumsikan berbeda-beda. Data nilai dibuat acak. Contohnya seperti ini :

    contoh-tabel.png

    Contoh script terlampir. Silahkan diinformasikan kembali jika terjadi kesalahan (Error), karena pada contoh ini saya menggunakan objek eksternal untuk mensortir data sufiksnya. Semoga sesuai...

    Demikian.

 

atau Mendaftar untuk ikut berdiskusi!