Gửi bởi
tiamo2_2
tại các số dòng có thể thay đổi tùy thuộc vào file natepad. mình có để các vùng trong excel lại đều là 50, bạn xem giúp minh cái nha. thanks bạn
thử xài code này xem sao
Mã:
Public Sub hello()
Dim objStream, strData As String, rex As Object, c As Long, tmp
Dim arr, r As Long, str As String, dic As Object, arrText, arRows, arCols
Dim i As Long, j As Long, cRow As Long, dArr
Set dic = CreateObject("Scripting.Dictionary")
Set rex = CreateObject("VBScript.RegExp")
Set objStream = CreateObject("ADODB.Stream")
rex.Pattern = "\s{2,}"
rex.Global = True
objStream.Charset = "utf-8"
objStream.Open
objStream.LoadFromFile (ThisWorkbook.Path & "\file goc.stxt")
strData = objStream.ReadText()
objStream.Close
With Sheet2
arr = .Range("B1:L" & .[B50000].End(xlUp).Row)
For r = 1 To UBound(arr) Step 1
If arr(r, 1) = "ID" Then
dic(arr(r - 1, 1)) = r
End If
Next
arrText = Split(strData, vbCrLf & "*")
For r = 0 To UBound(arrText) Step 1
str = "*" & Left(arrText(r), WorksheetFunction.Max(1, InStr(arrText(r), vbCrLf) - 1))
If dic.exists(str) Then
cRow = dic(str)
dic(str) = -1
str = Mid(arrText(r), InStrRev(arrText(r), "===" & vbCrLf) + 5)
arRows = Split(str, vbCrLf)
ReDim dArr(1 To 50, 1 To UBound(arr, 2) - 1)
For i = 0 To WorksheetFunction.Min(UBound(arRows), UBound(dArr) - 1) Step 1
arRows(i) = rex.Replace(arRows(i), "helloworld")
arCols = Split(arRows(i), "helloworld")
If UBound(arCols) > 1 Then
j = 0
For c = 2 To UBound(arr, 2) Step 1
If arr(cRow, c) <> "" Then
If j <= UBound(arCols) Then dArr(i + 1, c - 1) = arCols(j)
j = j + 1
End If
Next
End If
Next
.Range("C" & cRow + 2).Resize(UBound(dArr), UBound(dArr, 2)).Value = dArr
End If
Next
For Each tmp In dic.keys
If dic(tmp) > 0 Then .Range("C" & dic(tmp) + 2).Resize(50, UBound(arr, 2) - 1).ClearContents
Next
End With
End Sub