Hai pak Ubaidil Alif, coba solusi VBA berikut, ditulis dalam sebuah modul:
Option Explicit
Public Sub ExtractOneLineCellToMultipleCells()
Dim i As Integer, j As Integer, x As Integer, iData As Integer, iCol As
Integer
Dim lRow As Long
Dim rngData As Range, rngResult As Range
Dim TempArray() As Variant, myArray As Variant
Dim sTimer As Single
Application.ScreenUpdating = False
sTimer = Timer
Set rngData = Sheets("data awal").Range("a2")
ReDim TempArray(1)
TempArray(1) = WorksheetFunction.Substitute(rngData, Chr(10), "#")
iData = Len(TempArray(1))
i = iData - Len(WorksheetFunction.Substitute(TempArray(1), "#", "")) + 1
ReDim myArray(x = 1 To i, 1 To 2)
x = 1
For j = 1 To iData
If Mid(TempArray(1), j, 1) = "#" Then
myArray(x, 1) = x
myArray(x, 2) = Left(TempArray(1), j - 1)
TempArray(1) = Mid(TempArray(1), j + 1, 9 ^ 9)
j = 1
x = x + 1
iData = Len(TempArray(1))
End If
Next j
myArray(x, 1) = x
myArray(x, 2) = TempArray(1)
With Sheets("data olahan")
Set rngResult = .Range(.Cells(1, 1), .Cells(x + 1, 2))
rngResult = myArray
.Range("a1").Value = "RecNo"
.Range("b1").Value = "No"
.Range("c1").Value = "Data 1"
.Range("d1").Value = "Data 2"
.Range("e1").Value = "Data 3"
.Range("f1").Value = "Data 4"
Application.DisplayAlerts = False
Set rngData = .Range(.Cells(2, 2), .Cells(x + 1, 2))
rngData.TextToColumns Destination:=.Range("B2"), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=True, _
Tab:=False, _
Semicolon:=False, _
Comma:=False, _
Space:=True, _
Other:=False, _
FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1),
Array(4, 1), Array(5, 1)), _
TrailingMinusNumbers:=True
Application.DisplayAlerts = True
End With
Sheets("data olahan").Select
Range("a1").CurrentRegion.Columns.AutoFit
Application.ScreenUpdating = True
MsgBox "Berhasil memisahkan " & x & " data dalam waktu " & Format(Timer
- sTimer, "0.000") & " detik", vbOKOnly, "Done"
End Sub
sekalian tanya ke para master, bagaimana cara melakukan looping untuk skrip
yang diwarnai dengan merah, karena untuk proses pemecahan data dari Text ke
Kolom saya menggunakan record macro.
file terlampir semoga bermanfaat,
Wassalam,
-Aji Mumpung-
Pada 8 April 2013 09.13, Ubaidil Alif <[email protected]> menulis:
> **
>
>
> Selamat pagi Para Master dan Be Exceller
>
> Mohon bantuannya ni. Saya mau memisahkan data yang ada seperti di contoh
> yang saya lampirkan. Bagaimana caranya ya?
>
> Terima kasih
> Ubaidil Alif
>
CellToMultipleCellsWithVBA.xlsb
Description: Binary data
