Xin giúp thêm code lấy "Source Filename"

happyghost2000 · 6/7/20

Chào các Anh, Chị . Em có đoạn code coppy các file text vào 1 file excel . Trong đoạn code này em muốn thêm lấy "Source Filename" vào cột cuối hay cột đầu của dữ liệu coppy .
Mong Anh, Chị thêm dùm em với . Em cám ơn nhiều

Mã:

Sub Kho_Thanh_Pham()
Dim Index As Long, n As Long, col As Long, row As Long, Text As String
Dim Rng As Range, FSO As Object, FilesToImport
Dim TextSource As Object, NumOfLines, Cols, Res()
Sheets("ONVKSOKO").Range("A2:L65536").ClearContents
Set Rng = Sheets("ONVKSOKO").Range("A2")
FilesToImport = Application.GetOpenFilename("Text Files (*.txt), *.txt", , , , True)
If IsArray(FilesToImport) Then
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Index = 1 To UBound(FilesToImport)
        n = 0
        Set TextSource = FSO.OpenTextFile(FilesToImport(Index), 1, , -2)
        NumOfLines = Split(TextSource.ReadAll, vbCrLf)
       
        If UBound(NumOfLines) > 0 Then
            ReDim Res(1 To UBound(NumOfLines), 1 To 1)
            For row = 1 To UBound(NumOfLines)
                Text = NumOfLines(row)
                If Text <> "" Then
                    If Text <> String(Len(Text), ",") Then
                        n = n + 1
                        Cols = Split(Text, ",")
                        If UBound(Res, 2) < UBound(Cols) + 1 Then
                            ReDim Preserve Res(1 To UBound(NumOfLines), 1 To UBound(Cols) + 1)
                        End If
                        For col = 1 To UBound(Res, 2)
                            Res(n, col) = Replace(Cols(col - 1), """", "")
                        Next
                    End If
                End If
            Next
        End If
        Rng.Resize(n, UBound(Res, 2)).Value = Res
        Set Rng = Rng.Offset(n)
    Next
End If
End Sub

huuthang_bd · 6/7/20

Những chỗ màu đỏ là thêm vào hoặc chỉnh sửa. Code chưa test.

Rich (BB code):

Sub Kho_Thanh_Pham()
Dim Index As Long, n As Long, col As Long, row As Long, Text As String
Dim Rng As Range, FSO As Object, FilesToImport
Dim TextSource As Object, NumOfLines, Cols, Res()
Sheets("ONVKSOKO").Range("A2:L65536").ClearContents
Set Rng = Sheets("ONVKSOKO").Range("A2")
FilesToImport = Application.GetOpenFilename("Text Files (*.txt), *.txt", , , , True)
If IsArray(FilesToImport) Then
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Index = 1 To UBound(FilesToImport)
        n = 0
        Set TextSource = FSO.OpenTextFile(FilesToImport(Index), 1, , -2)
        NumOfLines = Split(TextSource.ReadAll, vbCrLf)
     
        If UBound(NumOfLines) > 0 Then
            ReDim Res(1 To UBound(NumOfLines), 0 To 1)
            For row = 1 To UBound(NumOfLines)
                Text = NumOfLines(row)
                If Text <> "" Then
                    If Text <> String(Len(Text), ",") Then
                        n = n + 1
                        Cols = Split(Text, ",")
                        If UBound(Res, 2) < UBound(Cols) + 1 Then
                            ReDim Preserve Res(1 To UBound(NumOfLines), 0 To UBound(Cols) + 1)
                        End If
                        Res(0, col) = FilesToImport(Index)
                        For col = 1 To UBound(Res, 2)
                            Res(n, col) = Replace(Cols(col - 1), """", "")
                        Next
                    End If
                End If
            Next
        End If
        Rng.Resize(n, UBound(Res, 2) + 1).Value = Res
        Set Rng = Rng.Offset(n)
    Next
End If
End Sub

happyghost2000 · 6/7/20

huuthang_bd đã viết:

Những chỗ màu đỏ là thêm vào hoặc chỉnh sửa. Code chưa test.

Rich (BB code):

Sub Kho_Thanh_Pham()
Dim Index As Long, n As Long, col As Long, row As Long, Text As String
Dim Rng As Range, FSO As Object, FilesToImport
Dim TextSource As Object, NumOfLines, Cols, Res()
Sheets("ONVKSOKO").Range("A2:L65536").ClearContents
Set Rng = Sheets("ONVKSOKO").Range("A2")
FilesToImport = Application.GetOpenFilename("Text Files (*.txt), *.txt", , , , True)
If IsArray(FilesToImport) Then
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Index = 1 To UBound(FilesToImport)
        n = 0
        Set TextSource = FSO.OpenTextFile(FilesToImport(Index), 1, , -2)
        NumOfLines = Split(TextSource.ReadAll, vbCrLf)
    
        If UBound(NumOfLines) > 0 Then
            ReDim Res(1 To UBound(NumOfLines), 0 To 1)
            For row = 1 To UBound(NumOfLines)
                Text = NumOfLines(row)
                If Text <> "" Then
                    If Text <> String(Len(Text), ",") Then
                        n = n + 1
                        Cols = Split(Text, ",")
                        If UBound(Res, 2) < UBound(Cols) + 1 Then
                            ReDim Preserve Res(1 To UBound(NumOfLines), 0 To UBound(Cols) + 1)
                        End If
                        Res(0, col) = FilesToImport(Index)
                        For col = 1 To UBound(Res, 2)
                            Res(n, col) = Replace(Cols(col - 1), """", "")
                        Next
                    End If
                End If
            Next
        End If
        Rng.Resize(n, UBound(Res, 2) + 1).Value = Res
        Set Rng = Rng.Offset(n)
    Next
End If
End Sub

Dạ cám ơn Anh, để mình test thử .

Bài đã được tự động gộp: 6/7/20

@huuthang_bd báo lỗi dòng này

huuthang_bd · 6/7/20

Tôi nhầm, Res(n, 0) nhé.

happyghost2000 · 6/7/20

huuthang_bd đã viết:
Tôi nhầm, Res(n, 0) nhé.

Cám ơn bác gần đúng rồi . Nhưng em chỉ muốn lấy tên file thôi bác . thì phải làm sao ?
VD : 201904NVKSOKO1 -> Chỉ vậy thôi .
Bên dưới code chạy ra luôn đường dẫn .

C:\Users\ORGAN_DELL\Desktop\DU LIEU KHO P1,3,5 (042019-032020)\KSOKO 201904-202003\201904ONVKSOKO1.TXT

befaint · 6/7/20

happyghost2000 đã viết:
lấy tên

Res(n, 0) = FSO.GetBaseName(FilesToImport(Index))

huuthang_bd · 6/7/20

Bạn sửa lại như sau:

Mã:

Res(n, 0) = FSO.GetBaseName(FilesToImport(Index))

happyghost2000 · 6/7/20

huuthang_bd đã viết:
Bạn sửa lại như sau:

Mã:

Res(n, 0) = FSO.GetBaseName(FilesToImport(Index))

Thật tuyệt vời . Chân thành cám ơn bác @huuthang_bd

happyghost2000 · 21/7/20

happyghost2000 đã viết:
Thật tuyệt vời . Chân thành cám ơn bác @huuthang_bd

Anh @huuthang_bd Anh giúp em thêm 1 yêu cầu nữa nhé .
Khi em coppy vào OK hết nhưng dữ liệu chưa hoàn chỉnh .
cột thứ 2 đến cột 4 ( tương đương cột B ~ cột E ) dữ liệu từ dòng số 3 đến dòng số 4 bị trống , em muốn coppy dòng B2:E2 vào B3:E3 , B4:E4 và làm tiếp coppy B5:E5 cho dòng B6:E6 & B7:E7 , cứ thế B8:E8 coppy.... .
Nhờ Anh @huuthang_bd thêm code giúp em . Em chân thành cảm ơn .

Mã:

Sub SUIKO_NM()
Dim Index As Long, n As Long, col As Long, row As Long, Text As String
Dim Rng As Range, FSO As Object, FilesToImport
Dim TextSource As Object, NumOfLines, Cols, Res()
Sheets("ONVSUIKO_NM").Range("A2:V300000").ClearContents
Set Rng = Sheets("ONVSUIKO_NM").Range("A2")
FilesToImport = Application.GetOpenFilename("Text Files (*.txt), *.txt", , , , True)
If IsArray(FilesToImport) Then
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Index = 1 To UBound(FilesToImport)
        n = 0
        Set TextSource = FSO.OpenTextFile(FilesToImport(Index), 1, , -2)
        NumOfLines = Split(TextSource.ReadAll, vbCrLf)
    
        If UBound(NumOfLines) > 0 Then
            ReDim Res(1 To UBound(NumOfLines), 0 To 1)
            For row = 1 To UBound(NumOfLines)
                Text = NumOfLines(row)
                If Text <> "" Then
                    If Text <> String(Len(Text), ",") Then
                        n = n + 1
                        Cols = Split(Text, ",")
                        If UBound(Res, 2) < UBound(Cols) + 1 Then
                            ReDim Preserve Res(1 To UBound(NumOfLines), 0 To UBound(Cols) + 1)
                        End If
                        'Res(n, 0) = Mid(FilesToImport(Index), InStrRev(FilesToImport(Index), "\") + 1)
                        Res(n, 0) = FSO.GetBaseName(FilesToImport(Index))
                        For col = 1 To UBound(Res, 2)
                            Res(n, col) = Replace(Cols(col - 1), """", "")
                        Next
                    End If
                End If
            Next
        End If
        Rng.Resize(n, UBound(Res, 2) + 1).Value = Res
        Set Rng = Rng.Offset(n)
    Next
End If
End Sub

happyghost2000 · 21/7/20

Anh @huuthang_bd ơi giúp em với

huuthang_bd · 21/7/20

Bạn thêm đoạn màu đỏ vào nhé

Rich (BB code):

For col = 1 To UBound(Res, 2)
    Res(n, col) = Replace(Cols(col - 1), """", "")
Next
If n Mod 3 <> 1 Then
    For col = 1 To 4
        Res(n, col) = Res(n - 1, col)
    Next
End If

happyghost2000 · 22/7/20

huuthang_bd đã viết:
Bạn thêm đoạn màu đỏ vào nhé

Rich (BB code):

For col = 1 To UBound(Res, 2) Res(n, col) = Replace(Cols(col - 1), """", "") Next If n Mod 3 <> 1 Then For col = 1 To 4 Res(n, col) = Res(n - 1, col) Next End If

Bác hay thật , cám bác nhiều @huuthang_bd

Xin giúp thêm code lấy "Source Filename"

happyghost2000

Thành viên chính thức

File đính kèm

huuthang_bd

Chuyên gia GPE

happyghost2000

Thành viên chính thức

huuthang_bd

Chuyên gia GPE

happyghost2000

Thành viên chính thức

befaint

|||||||||||||

huuthang_bd

Chuyên gia GPE

happyghost2000

Thành viên chính thức

happyghost2000

Thành viên chính thức

happyghost2000

Thành viên chính thức

huuthang_bd

Chuyên gia GPE

happyghost2000

Thành viên chính thức

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng