Kang zainul, mantap jalan lancar. Setelah dimengerti codingnya, ijin untuk modifikasi sedikit ya.
Trims banget ;) regards, Wira 鄧又銘 Note 2 on Super 3G+ On Jul 1, 2013 10:12 PM, "zainul_ulum[at]yahoo[dot]com" < [email protected]> wrote: > ** > > > Kang Wira, > silahkan dicoba vba code berikut: > '====== > Option Explicit > Sub TransformData() > Dim rgDataAsal As Range > > With Worksheets("Sheet1") > '1. menentukan range yang akan ditransform dan jumlah record > Set rgDataAsal = .Range("A1").CurrentRegion > > '2. sort data asal berdasarkan field 'relno' > rgDataAsal.Sort key1:=.Range("A1"), order1:=xlAscending, Header:=xlYes > > '3. menentukan range relno dimulai dari baris kedua > Dim rgRelNo As Range, nRecs As Long > nRecs = rgDataAsal.Rows.Count - 1 > Set rgRelNo = .Range("A2").Resize(nRecs, 1) > > '4. mengumpulkan nomor relno > Dim rgCell As Range 'cell relno > Dim i As Long, j As Long, nAcc As Long > Dim DataBaru() As Variant > i = -1 > For Each rgCell In rgRelNo.Cells > '4.1. jika nilai relno TIDAK SAMA dengan baris sebelumnya > If rgCell.Value <> rgCell.Offset(-1, 0).Value Then > i = i + 1 > ReDim Preserve DataBaru(8, i) > DataBaru(0, i) = rgCell 'norel > DataBaru(1, i) = rgCell.Offset(, 1) 'nama > DataBaru(7, i) = rgCell.Offset(, 4) 'address 1 > DataBaru(8, i) = rgCell.Offset(, 5) 'address 2 > > '4.2. mengumpulkan banyaknya account tiap relno > nAcc = WorksheetFunction.CountIf(rgRelNo, rgCell) > For j = 0 To nAcc - 1 > DataBaru(2 + j, i) = rgCell.Offset(j, 2) & " " & > rgCell.Offset(j, 3) > Next j > > End If > Next > > End With > > '5. mencetak di sheet yang diinginkan > Dim NewRecs As Long > NewRecs = UBound(DataBaru, 2) + 1 > With Worksheets("diinginkan") > '5.1. menghapus data sebelumnya jika sudah ada > .Range("A2").Resize(10000, 9).Clear > > '5.2. tulis data baru > .Range("A2").Resize(NewRecs, 9) = > WorksheetFunction.Transpose(DataBaru) > .Activate > End With > > End Sub > > '===== > > From: [email protected] [mailto:[email protected]] > On Behalf Of WIRAnata Kemala > Sent: Monday, July 01, 2013 7:38 PM > To: [email protected] > Subject: [belajar-excel] multiple records (rows) jadi kolom > > > dear all, > bisa minta tolong bantuannya untuk memindahkan multiple records (rows) jadi > multiple kolom? > untuk lebih jelasnya, saya attach yah xls nya. > mohon bantuannya dalam VBA yah - sekalian newbie belajar vba :) > > thanks atas bimbingan dan kesabaran rekan-rekan :) > salam. > > >
