Lấy dữ liệu từ file notepad sang excel (2 người xem)

[tiamo2_2]

Chào các bạn.
Mình đang có một vấn đề cần nhờ các cao thủ hihi
Mình có 1 file dư liệu dạng notepad giờ mình muốn các bạn giúp mình viết code lấy dữ liệu từ notepad đấy chuyển sang file excel theo các hàng đã định sẵn tròng excel.
mình có file đinh kèm các bạn xem giúp mình với, mình đã tham khảo một số code trên diễn đàn nhưng ko phù hợp.
cảm ơn các bạn nhiều!
note: các dòng thì có thể thay đổi thêm hoặc bớt tùy thuộc vào file nguồn.

 

[doveandrose]

dữ liệu của Position X=81.9(Degree of Consolidation) tôi đếm sơ sơ thấy ba mấy dòng mà bạn chừa chỗ có 30 dòng trong excel vậy sao chơi ?

rồi các vùng trong excel cái thì chừa 30 dòng , cái thì 20 dòng vậy cũng được sao ?

 

[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

 

[doveandrose]

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

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

 

[Kiều Mạnh]

thử xài code này xem sao

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

lâu lắm rồi mới thấy code hay
Mạnh hoc được dòng sau sử dụng ADO lấy dữ liệu gán vào strData... hay...

objStream.LoadFromFile (ThisWorkbook.Path & "\file goc.stxt")

 

[tiamo2_2]

cảm ơn bạn doveandrose nhiều code dùng rất ổn. nhưng cho minh hỏi thêm là có thể tự động ẩn đi các dòng trống ở các vùng đc không?

 

[doveandrose]

cảm ơn bạn doveandrose nhiều code dùng rất ổn. nhưng cho minh hỏi thêm là có thể tự động ẩn đi các dòng trống ở các vùng đc không?

điền mấy chữ vào ô M2 :

=NOT( AND(ISNUMBER(B5);$C5=""))

ô M1 để trống

thay dòng này trong sub hello

End With

bằng

.Range("B4:C587").AdvancedFilter xlFilterInPlace, .Range("M1:M2"), , False
End With

 

[tiamo2_2]

"=NOT( AND(ISNUMBER(B5);$C5=""))"
code này copy vào đâu bạn ơi? hihi

 

[doveandrose]

"=NOT( AND(ISNUMBER(B5);$C5=""))"
code này copy vào đâu bạn ơi? hihi

điền mấy chữ vào ô M2 :

ở chỗ này nè .......