Coba routine berikut :
Public Sub Ekstarksi()
Dim rng As Range, rngData As Range, rngItem As Range, rngTarget As Range
Dim lItem As Long
Application.ScreenUpdating = False
ActiveSheet.AutoFilterMode = False
'buat header jika belum punya header dengan teks mydata
If InStr(Range("a1").Value, "mydata") = 0 Then
Rows("1:1").Insert Shift:=xlDown
Range("A1").Value = "mydata"
End If
Set rngData = Range("a1").CurrentRegion 'init
range data
rngData.Sort Range("a1"), xlAscending, Header:=xlYes 'sort
data
'ekstrak kriteria ke kolom C
rngData.TextToColumns Range("c1"), xlFixedWidth,
FieldInfo:=Array(Array(0, 2), Array(11, 9))
Range("c1").CurrentRegion.RemoveDuplicates 1, xlYes 'remove
duplicate kriteria
Set rngItem = Range("c1").CurrentRegion.Offset(1) 'init range
item kriteria
Sheet2.Range("a1").CurrentRegion.EntireRow.Delete 'delete
hasil yang lama
Set rngTarget = Sheet2.Range("a1") 'init
anchor hasil yang baru
lItem = 0
rngData.AutoFilter
For Each rng In rngItem
If LenB(rng.Value) <> 0 Then
rngData.AutoFilter 1, rng.Value & "*"
rngData.SpecialCells(xlCellTypeVisible).Copy
rngTarget.Offset(, lItem).PasteSpecial xlPasteValues
lItem = lItem + 1
End If
Next
ActiveSheet.AutoFilterMode = False
'finishing
rngItem.EntireColumn.Delete 'buang
kolom item kriteria
rngTarget.CurrentRegion.Resize(1).EntireRow.Delete 'buang
header hasil
rngData.Resize(1).EntireRow.Delete 'buang
header data
Application.ScreenUpdating = True
MsgBox "Done."
End Sub
Regards,
Kid.
2012/2/3 andri apriyadi <[email protected]>
> **
>
>
> Salam Para Pakar Excel
>
> Jika dengan menggunakan tombol Makro, bagaimana mengekstraksi deretan data
> vertikal menjadi data berbentuk horizontal (menyamping) sesuai dengan
> kategorinya?
>
> Contoh kasus ada dalam lampiran. Terima Kasih atas bantuannya.
>
> Regards
>
>
> Andree
>
>
>
>
