Chuyển số liệu từ Notepad----->Excel (1 người xem)

[phulien1902]

Em có 1 file số liệu trong Notepad. Số liệu bắt đầu từ nhóm 48*** và kết thúc bởi "=". Bây giờ em muốn chuyển số liệu này sang file Excel với điều kiện nhóm 48*** nằm trong 1 cell, các nhóm tiếp theo( cách nhau 1 khoảng trống) sẽ nằm lần lượt trong các cell tiếp theo. Vậy phải làm như thế nào, mong mọi người giúp đỡ. Xin trân trọng cảm ơn!
P/s: Em có đính kèm File Excel mong muốn( Book1112)

 

[phulien1902]

Buồn quá, hơn 1 tháng mà không có ai giúp mình.

 

[hungpecc1]

Buồn quá, hơn 1 tháng mà không có ai giúp mình.

thử code này xem ( đang vội , viêt tạm, chưa test đúng sai !)
[GPECODE=vb]
Sub NMH()
Dim FSo As Object, txtstream As Object, objmatch As Object
Dim reg As Object
Dim FileName$, i&, j&, tmpString$, Arr(), tmpArr$(), n&
Set FSo = CreateObject("scripting.filesystemobject")
Set reg = CreateObject("vbscript.regexp")
FileName = ThisWorkbook.Path & "\Data300.txt"
With FSo
Set txtstream = .OpenTextFile(FileName)
tmpString = txtstream.ReadAll
txtstream.Close
End With
With reg
.Global = True: .MultiLine = True
.Pattern = "^48(?:.|\n)+?=$"
Set objmatch = .Execute(tmpString)
n = objmatch.Count
ReDim Arr(0 To n, 0 To 0)
For i = 0 To n - 1
tmpString = objmatch(i)
tmpArr = Split(tmpString, " ")
ReDim Preserve Arr(0 To n, 0 To UBound(tmpArr))
For j = 0 To UBound(tmpArr)
Arr(i, j) = tmpArr(j)
Next
Next
End With
Range("A1").Resize(n + 1, UBound(Arr, 2) + 1) = Arr
Set FSo = Nothing
End Sub
[/GPECODE]

 

[phulien1902]

Cảm ơn anh hungpecc1 đã xem giúp em. Em cũng đã thử Code nhưng chuỗi số liệu vẫn chưa sắp xếp hết vào các Cell( Bắt đầu bằng 48*** và kết thúc bằng"=").
Khi nào anh rảnh anh xem giúp em với nhé.
Cảm ơn anh trước.

 

[siwtom]

thử code này xem ( đang vội , viêt tạm, chưa test đúng sai !)
[GPECODE=vb]
Sub NMH()
Dim FSo As Object, txtstream As Object, objmatch As Object
Dim reg As Object
Dim FileName$, i&, j&, tmpString$, Arr(), tmpArr$(), n&
Set FSo = CreateObject("scripting.filesystemobject")
Set reg = CreateObject("vbscript.regexp")
FileName = ThisWorkbook.Path & "\Data300.txt"
With FSo
Set txtstream = .OpenTextFile(FileName)
tmpString = txtstream.ReadAll
txtstream.Close
End With
With reg
.Global = True: .MultiLine = True
.Pattern = "^48(?:.|\n)+?=$"
Set objmatch = .Execute(tmpString)
n = objmatch.Count
ReDim Arr(0 To n, 0 To 0)
For i = 0 To n - 1
tmpString = objmatch(i)
tmpArr = Split(tmpString, " ")
ReDim Preserve Arr(0 To n, 0 To UBound(tmpArr))
For j = 0 To UBound(tmpArr)
Arr(i, j) = tmpArr(j)
Next
Next
End With
Range("A1").Resize(n + 1, UBound(Arr, 2) + 1) = Arr
Set FSo = Nothing
End Sub
[/GPECODE]

Code có chút lỗi. Ta mổ xẻ chút chút nhé

1. Tôi đổi pattern thành

.Pattern = "^48(?:.|\n)+?(?==$)"
hoặc (vì "=" chỉ thấy ở cuối)
.Pattern = "^48(?:.|\n)+?(?==)"

2.

tmpArr = Split(tmpString, " ")

Làm như trên không được vì chuỗi chứa cả 2 ký tự vbCrLf thay cho " "

3.

ReDim Preserve Arr(0 To n, 0 To UBound(tmpArr))

Làm như thế không được. Nếu dòng trước rất dài mà dòng hiện hành ngắn thì làm thế là cắt cụt kết quả của dòng trước mất rồi. Thậm chí nếu dòng sau dòng hiện hành rất dài thì có Redim "dài lại" thì dữ liệu của dòng rất dài "kia" cũng đã mất toi rồi.

Tôi thử sửa như sau (vẫn giữ nguyên ý tưởng):

Sub NMH()
    Dim FSo As Object, txtstream As Object, objmatch As Object, maxcolcount As Long
    Dim reg As Object
    Dim FileName$, i&, j&, tmpString$, Arr(), tmpArr$(), n&
        Set FSo = CreateObject("scripting.filesystemobject")
        Set reg = CreateObject("vbscript.regexp")
        FileName = ThisWorkbook.Path & "\Data300.txt"
        With FSo
            Set txtstream = .OpenTextFile(FileName)
            tmpString = txtstream.ReadAll
            txtstream.Close
        End With
        With reg
            .Global = True: .MultiLine = True
            .Pattern = "^48(?:.|\n)+?(?==$)"
            Set objmatch = .Execute(tmpString)
            n = objmatch.Count
            ReDim Arr(1 To n, 1 To 1)
            For i = 1 To n
                tmpString = Replace(objmatch(i - 1), vbCrLf, " ")
                tmpArr = Split(tmpString, " ")
                If UBound(tmpArr) + 1 > maxcolcount Then
                    maxcolcount = UBound(tmpArr) + 1
                    ReDim Preserve Arr(1 To n, 1 To maxcolcount)
                End If
                For j = 0 To UBound(tmpArr)
                    Arr(i, j + 1) = tmpArr(j)
                Next
            Next
        End With
        Range("A1").Resize(n, maxcolcount) = Arr
        Set FSo = Nothing
End Sub

 

[phulien1902]

Xin chân thành cảm ơn Siwtom đã ghé thăm và giải quyết khó khăn giúp mình, Code của bạn sử dụng quá tuyêt vời luôn, vô cùng quý giá. Mình sẽ ứng dụng nó vào công việc của mình. Một lần nữa xin cảm ơn bạn rất nhiều, rất nhiều.