Gán code dưới đây vào nút nào đó rồi chạy
Option Explicit
Sub abc()
Dim Nguon
Dim Kq
Dim i, j, k
Nguon = Sheet1.Range("A1").CurrentRegion
k = Len(Nguon(1, 1)) - Len(Replace(Nguon(1, 1), ",", "")) + 1
ReDim Kq(1 To UBound(Nguon), 1 To k)
For i = 1 To UBound(Nguon)
k = 0
For Each j In Split(Nguon(i, 1), ",")
k = k + 1
Kq(i, k) = Replace(j, """", "")
Next j
Next i
With Sheet2.Range("A1").Resize(UBound(Kq), UBound(Kq, 2))
.Clear
.Value = Kq
.Columns.AutoFit
End With
End Sub
Ghi Macro rồi sửa lại một chút:
Sub Macro1()
With Sheets("FILE_20210827_075012_codes_2021")
.Range("A1", .Range("A1").End(xlDown)).Copy Sheets("KetQua").Range("A1")
End With
With Sheets("KetQua")
.Range("A1", .Range("A1").End(xlDown)).TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, Other:=True, OtherChar _
:=",", TrailingMinusNumbers:=True
End With
End Sub
Chạy code và kiểm tra kết quả. hy vọng đúng ý.
Option Explicit
Sub TACH()
Dim i&, j&, Lr&, t&
Dim Arr(), S, tmp, Temp
Lr = Sheet1.Cells(Rows.Count, 1).End(3).Row
Arr = Sheet1.Range("A1:A" & Lr).Value
ReDim KQ(1 To UBound(Arr), 1 To 20)
For i = 1 To UBound(Arr)
tmp = Replace(Trim(Arr(i, 1)), """", " ")
Temp = Split(tmp, ",")
t = 0
For j = 0 To UBound(Temp) Step 1
If Temp(j) <> Empty Then t = t + 1: KQ(i, t) = Temp(j)
Next j
Next i
Sheet2.[A1].Resize(i, UBound(Temp)) = KQ
Sheet2.[A1].Resize(i, UBound(Temp)).EntireColumn.AutoFit
Sheet2.Columns("A:A").NumberFormat = "m/d/yyyy"
End Sub
[\code]
Sub TextToColumn(SourceRange As Range, Delimiter As String, ResultWs As Worksheet, ResultCell As String)
'SourceRange: vung du lieu can tach dong
'Delimiter: ky tu de phan tach dong
'ResultWs: Sheet dien ket qua
'ResultCell: o dien ket qua
Dim sArr(), Res(), Tmp
Dim Col As Byte, I As Integer, J As Byte, CountDelimiter As Byte, K As Integer
If SourceRange.Columns.Count > 1 Then Exit Sub
If Range(ResultCell).Rows.Count > 1 Or Range(ResultCell).Columns.Count > 1 Then Exit Sub
CountDelimiter = Len(CStr(SourceRange(1, 1))) - Len(Replace(CStr(SourceRange(1, 1)), Delimiter, "")) + 1
sArr() = SourceRange.Value
ReDim Res(1 To UBound(sArr, 1), 1 To CountDelimiter)
For I = 1 To UBound(sArr, 1)
Tmp = Split(sArr(I, 1), ",")
K = K + 1
For J = 0 To UBound(Tmp)
Res(K, J + 1) = Replace(CStr(Tmp(J)), """", "")
Next J
Next
ResultWs.Range(ResultCell).CurrentRegion.ClearContents
ResultWs.Range(ResultCell).Resize(K, CountDelimiter) = Res
ResultWs.Range(ResultCell).CurrentRegion.EntireColumn.AutoFit
End Sub
Sub Main()
Dim Rng As Range
Set Rng = Sheet1.Range("A1", Sheet1.Range("A1").End(xlDown))
Call TextToColumn(Rng, ",", Sheet2, "A1")
Set Rng = Nothing
MsgBox "Done", vbInformation, "GPE"
End SubKhông ngờ có phản hồi nhanh vậy. Rất cảm ơn mọi người nhé. Có điều chỉ có Code của @CHAOQUAY là chạy được và ra kết quả như ý. Bản của bạn @Phuocam và @HUONGHCKT chưa chạy được, để mình thử thêm.
Sub ABC()
Dim sArr(), Res(), K&, i&, j&, T
With Sheet1
sArr = .Range("A1").CurrentRegion.Value
End With
For i = 1 To UBound(sArr, 1)
K = K + 1
T = Split(Replace(sArr(i, 1), """", ""), ",")
ReDim Preserve Res(1 To UBound(sArr, 1), 1 To UBound(T) + 1)
For j = 0 To UBound(T)
Res(K, j + 1) = T(j)
Next
Next
With Sheet2
.Range("M1").Resize(10000, 1000).ClearContents
.Range("M1").Resize(K, UBound(T) + 1).Value = Res
End With
End Sub
