Coba code berikut:
Sub TransformTabel()
Dim rgAsal As Range, rgTarget As Range
Const LebarTabelAsal As Integer = 2
Const SPASI As String = " "
'menentukan range target atau tujuan
Set rgTarget = Range("E1")
'membersihkan range target
rgTarget.Resize(10000, 100).Clear
'menentukan range/tabel asal
Set rgAsal = Range("A2") 'data pertama
'block ke bawah dari data pertama
Set rgAsal = Range(rgAsal, rgAsal.End(xlDown))
'block ke kanan menjadi dua kolom
Set rgAsal = rgAsal.Resize(, LebarTabelAsal)
'membaca data asal dimulai dari kolom pertama
Dim rg As Range
Dim i As Integer, j As Integer
Dim vIsi As Variant, v As Variant
Dim strHeader As String
'setting agar operasi lebih cepat
Application.ScreenUpdating = False
i = -1
For Each rg In rgAsal.Columns(1).Cells
i = i + 1
'nama kolom header A B C D
strHeader = rg.Value
'mencetak header di range tujuan atau range target
rgTarget.Offset(, i) = strHeader
'mengambil isi data tiap header
vIsi = Split(rg.Offset(, 1), SPASI)
'membaca data satu per satu dan mencetak ke target tujuan
j = 0
For Each v In vIsi
j = j + 1
rgTarget.Offset(j, i) = v
Next
Next
Application.ScreenUpdating = True
End Sub
From: [email protected] [mailto:[email protected]] On
Behalf Of [email protected]
Sent: Thursday, April 10, 2014 2:56 AM
To: [email protected]
Subject: [belajar-excel] Tanya copy data ke baris kanan [1 Attachment]
Minta tolong dibantu pak admin atau rekan semua permasalahan saya.. karena
masih tahap belajar VBA..
dari pencarian di google ada tapi dia otomatis terkopi ke bawah seluruhnya...
atas bantuannya saya ucapkan terima kasih
Sub COPAS()
Dim fromCol As String
Dim toCol As String
Dim fromRow As String
Dim toRow As String
Dim inVal As String
Dim outVal As String
Dim commaPos As Integer
Application.ScreenUpdating = False
' Copy from column B to column E.'
fromCol = "B"
toCol = "E"
fromRow = "1"
toRow = "1"
' Go until no more entries in column B.'
inVal = Range(fromCol + fromRow).Value
While inVal <> ""
' Go until all sub-entries used up.'
While inVal <> ""
Range(fromCol + fromRow).Select
' Extract each subentry.'
commaPos = InStr(1, inVal, " ")
While commaPos <> 0
' and write to output column.'
outVal = Left(inVal, commaPos - 1)
Range(toCol + toRow).Select
Range(toCol + toRow).Value = outVal
toRow = Mid(Str(Val(toRow) + 1), 2)
' Remove that sub-entry.'
inVal = Mid(inVal, commaPos + 1)
While Left(inVal, 1) = " "
inVal = Mid(inVal, 2)
Wend
commaPos = InStr(1, inVal, " ")
Wend
' Get last sub-entry (or full entry if no commas).'
Range(toCol + toRow).Select
Range(toCol + toRow).Value = inVal
toRow = Mid(Str(Val(toRow) + 1), 2)
inVal = ""
Wend
' Advance to next source row.'
fromRow = Mid(Str(Val(fromRow) + 1), 2)
Range(fromCol + fromRow).Select
inVal = Range(fromCol + fromRow).Value
Wend
End Sub
Pisah.xlsm
Description: application/vnd.ms-excel.sheet.macroenabled.12
