Hai Simaster,
Sepertinya bisa pakai fitur texttocolumns lalu di copas transpose.
Asumsinya :
1. hasil selalu di kolom E,
2. jumlah baris data tidak lebih dari 16K,
3. pakai xl2007 ke atas.
Langkahnya :
1. hapus hasil yang lama
2. kolom ke 2 data di texttocolumns opsi delimited dengan karakter spasi
sebagai delimiternya, dan destinasi di cell pertama kolom ke-3 data
3. hasil texttocolumns (tanpa data) di copy pastespecial transpose kolom ke
3 setelah hasil texttocolumns terluar sejajar data
4. copy kolom ke 1 data dan pastespecial transpose di baris 1 excel pada
kolom terkiri hasil transpose
5. hapus hasil texttocolumns
6. delete area range kosong dikanan data sampai 3 kolom sebelum kolom hasil
transpose setinggi jumlah baris hasil transpose
public sub TextToColTranspose()
dim rngData as range, rngPaste as range, lColsData as long, lColsSplit
as long
application.cutcopymode=false 'clear memori dari sisa-sisa copas
application.screenupdating=false 'cegah refresh layar
range("*e*2").currentregion.clear 'hapus hasil yang lama (dari e2 di
select all) --> langkah 1
'--> persiapan langkah 2
set rngdata=range("*a*2").currentregion.offset(0) 'ganti 0 dengan
jumlah baris header yang letaknya rapat dengan record pertama data
with rngdata 'fokus pada area range data
lcolsdata=.columns.count
.columns(2).texttocolumns destination:= .cells(1,lcolsdata+1),
space:=true '--> langkah 2
'--> persiapan langkah 3 dan seterusnya
lcolssplit= .currentregion.columns.count-lcolsdata 'jumlah kolom
hasil texttocolumns
'--> langkah 3
.columns(lcolsdata+1).resize(,lcolssplit).copy 'sisi copy data
sebelum pastespecial transpose
cells( .row,lcolsdata+lcolssplit+3).pastespecial transpose:=true
'pastespecial transpose ( .row untuk memastikan sejajar data )
'--> langkah 4
.columns(1).copy 'sisi copy kolom ke-1 data
cells( 1 , lcolsdata+lcolssplit+3).pastespecial xlpastevalues,
transpose:=true 'pastespecial values transpose ( 1 untuk memastikan di
baris 1 excel)
'--> langkah 5
.columns(lcolsdata+1).resize(, .lcolssplit).clear 'mulai kolom ke-3
data sebanyak jumlah kolom hasil texttocolumns dihapus
'--> langkah 6
cells( 1 , lcolsdata+1 ).resize( lcolssplit + *1* , lcolssplit).delete
xlshifttoleft 'angka 1 untuk mulai baris 1 dan +1 adalah baris header
hasil
end with
application.screenupdating=true 'boleh refresh layar lagi
application.cutcopymode=false 'clear memori dari sisa-sisa copas
end sub
*** catatan :
jika data tidak dimulai dari kolom A, maka ubah bagian :
1. huruf *e* pada range("*e*2") disesuaikan dengan menggeser kekanan hingga
ada 2 kolom kosong antara data dengan hasil
2. huruf *a *pada range("*a*2") disesuaikan agar merujuk ke cell pojok kiri
atas dari record pertama
3. angka 3 (yang biru saja) diganti dengan *2+.column*
4. angka 1 (yang biru saja) diganti dengan *.column*
Silakan disesuaikan dengan kebutuhan setempat dan dikoreksi error-error
yang muncul...
Jika ada pesan error tentang butuh ruang yang lebih luas, maka tutup Excel,
buka lagi, dan jalankan prosedur di atas.
Wassalam,
Kid.
On Thu, Apr 10, 2014 at 2:56 AM, <[email protected]> wrote:
>
>
> 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
>
>
>
