Xin giúp đỡ code VBA chép cột dữ liệu có điều kiện từ file này sang file khác

[acrox84]

Chào mọi người, mình làm ở điểm gom hàng Chuyển phát nhanh, nhiệm vụ của mình là mỗi thứ Hai, Tư, Sáu xuất file excel, lọc cột "Thời gian ký nhận" của shipper giao hàng thành công mà trả tiền cho Khách gửi.
Đầu tháng này, bên IT tăng độ khó game, tách cột cần thiết này qua file riêng khác, làm mình dò thủ công mờ cả mắt, chỉ sợ số liệu nhiều làm sai sót trả lộn tiền cho khách thì toi đời, nên mong mọi người giúp đỡ cách xử lý tốt hơn. Cảm ơn mọi người rất rất nhiều!

Mô tả vấn đề:
1) Dựa trên Mã Đơn (cột A) copy "Thời gian ký nhận" (cột L, file dulieu2) tương ứng sang cột trống AH ở file dulieu1
2) Do file dulieu1 và dulieu2, mình xuất và thay thế thường xuyên nên có tác giả nào cho file excel kèm nút đính code VBA có chức năng gộp 2 file thành file dulieu.xlsx thì mình tiện sử dụng hơn.
Đặc điểm 2 file này khi export ra là không thay đổi cấu trúc hoặc thứ tự các cột dữ liệu đều cố định như tệp đính kèm.

*Trường hợp đúng thì sẽ có kết quả mong muốn như thế này ở cột AH:


p/s: nếu yêu cầu nhờ vả có độ khó cao hoặc có gì quá đáng thì mong các bạn bỏ qua, nhu cầu của mình cấp thiết như thế mà cũng không quen bạn nào giỏi code VBA nên mạo muội lập thớt nhờ vả..
Chúc mọi người cuối tuần vui vẻ ^^!

 

[Hoàng Nhật Phương]

Chào mọi người, mình làm ở điểm gom hàng Chuyển phát nhanh, nhiệm vụ của mình là mỗi thứ Hai, Tư, Sáu xuất file excel, lọc cột "Thời gian ký nhận" của shipper giao hàng thành công mà trả tiền cho Khách gửi.
Đầu tháng này, bên IT tăng độ khó game, tách cột cần thiết này qua file riêng khác, làm mình dò thủ công mờ cả mắt, chỉ sợ số liệu nhiều làm sai sót trả lộn tiền cho khách thì toi đời, nên mong mọi người giúp đỡ cách xử lý tốt hơn. Cảm ơn mọi người rất rất nhiều!

Mô tả vấn đề:
1) Dựa trên Mã Đơn (cột A) copy "Thời gian ký nhận" (cột L, file dulieu2) tương ứng sang cột trống AH ở file dulieu1
2) Do file dulieu1 và dulieu2, mình xuất và thay thế thường xuyên nên có tác giả nào cho file excel kèm nút đính code VBA có chức năng gộp 2 file thành file dulieu.xlsx thì mình tiện sử dụng hơn.
Đặc điểm 2 file này khi export ra là không thay đổi cấu trúc hoặc thứ tự các cột dữ liệu đều cố định như tệp đính kèm.

*Trường hợp đúng thì sẽ có kết quả mong muốn như thế này ở cột AH:
View attachment 288630

p/s: nếu yêu cầu nhờ vả có độ khó cao hoặc có gì quá đáng thì mong các bạn bỏ qua, nhu cầu của mình cấp thiết như thế mà cũng không quen bạn nào giỏi code VBA nên mạo muội lập thớt nhờ vả..
Chúc mọi người cuối tuần vui vẻ ^^!

Bạn tham khảo :

Option Explicit

Private Sub CommandButton1_Click()
    
    Dim fso As Object, dic As Object
    Dim sheet As Worksheet, wbOpen As Workbook
    Dim arr As Variant
    Dim sFolderName As String, fileName As String
    Dim i As Long, r As Long
    Dim c As Integer
    Dim bFileOpened As Boolean
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    
    On Error GoTo End_
    
    Set sheet = ThisWorkbook.ActiveSheet
    sFolderName = sheet.Range("C4")
    fileName = sheet.Range("C8")
    Set fso = CreateObject("Scripting.FileSystemObject")
    GoSub checkBook_
    
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(arr, 1) + 1 To UBound(arr, 1)
        dic.Item(arr(i, 1)) = arr(i, 12)
    Next i
    If Not bFileOpened Then wbOpen.Close False
    Set wbOpen = Nothing
    fileName = sheet.Range("C6")
    GoSub checkBook_
    r = UBound(arr, 1): c = UBound(arr, 2) + 1
    ReDim Preserve arr(1 To UBound(arr, 1), 1 To c)
    For i = LBound(arr, 1) + 1 To UBound(arr, 1)
        If dic.Exists(arr(i, 1)) Then
            arr(i, c) = dic.Item(arr(i, 1))
        End If
    Next i
    With wbOpen.Worksheets(1).Range("A1")
        .Resize(r, c) = arr
        .Offset(, c - 1).Resize(r).NumberFormat = "yyyy-mm-dd hh:mm:ss"
    End With
    wbOpen.Save
    If Not bFileOpened Then wbOpen.Close False
    Set wbOpen = Nothing
    
    GoTo End_
    
checkBook_:
    If fso.FileExists(sFolderName & "\" & fileName) Then
        On Error Resume Next
        Set wbOpen = Workbooks(fileName)
        On Error GoTo 0
        If wbOpen Is Nothing Then
            Set wbOpen = Workbooks.Open(sFolderName & "\" & fileName)
            bFileOpened = False
        End If
        arr = wbOpen.Worksheets(1).Range("A1").CurrentRegion.Value
    Else
        MsgBox "Khong tim thay tap tin " & fileName & vbNewLine & _
            " trong thu muc " & sFolderName, vbCritical
        Exit Sub
    End If
    
    Return

End_:

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    
End Sub

 

[HUONGHCKT]

Chào mọi người, mình làm ở điểm gom hàng Chuyển phát nhanh, nhiệm vụ của mình là mỗi thứ Hai, Tư, Sáu xuất file excel, lọc cột "Thời gian ký nhận" của shipper giao hàng thành công mà trả tiền cho Khách gửi.
Đầu tháng này, bên IT tăng độ khó game, tách cột cần thiết này qua file riêng khác, làm mình dò thủ công mờ cả mắt, chỉ sợ số liệu nhiều làm sai sót trả lộn tiền cho khách thì toi đời, nên mong mọi người giúp đỡ cách xử lý tốt hơn. Cảm ơn mọi người rất rất nhiều!

Mô tả vấn đề:
1) Dựa trên Mã Đơn (cột A) copy "Thời gian ký nhận" (cột L, file dulieu2) tương ứng sang cột trống AH ở file dulieu1
2) Do file dulieu1 và dulieu2, mình xuất và thay thế thường xuyên nên có tác giả nào cho file excel kèm nút đính code VBA có chức năng gộp 2 file thành file dulieu.xlsx thì mình tiện sử dụng hơn.
Đặc điểm 2 file này khi export ra là không thay đổi cấu trúc hoặc thứ tự các cột dữ liệu đều cố định như tệp đính kèm

p/s: nếu yêu cầu nhờ vả có độ khó cao hoặc có gì quá đáng thì mong các bạn bỏ qua, nhu cầu của mình cấp thiết như thế mà cũng không quen bạn nào giỏi code VBA nên mạo muội lập thớt nhờ vả..
Chúc mọi người cuối tuần vui vẻ ^^!

Góp vui.
Bạn tham khảo code này xem sao, hy vọng đúng ý.
Lưu ý đường dẫn của tôi có thể khác của bạn.
Xem file đính kèm và nhấn nút "Chạy code" để có được kết quả.

Option Explicit

Sub ABC()
Dim i&, Lr&, R&, R1&
Dim Arr(), Arr1()
Dim dic As Object, Fso As Object, Key
Dim Ws As Worksheet, Sh As Worksheet, wb As Workbook
Dim File As Variant
Dim Path


With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    .Calculation = xlCalculationManual

Set Fso = CreateObject("Scripting.FileSystemObject")

Path = ActiveWorkbook.Path
On Error Resume Next
    For Each File In Fso.GetFolder(Path).Files
        If File.Name Like "*dulieu*" Then
            Set wb = Workbooks.Open(File)
            For Each Ws In wb.Worksheets
                If Ws.Name Like "Sheet0" Then
                    Lr = Ws.Cells(Rows.Count, 1).End(xlUp).Row
                    If File.Name Like "*dulieu1*" Then
                        Arr = Ws.Range("A1:AH" & Lr).Value2
                        R = UBound(Arr)
                    Else
                        Arr1 = Ws.Range("A2:L" & Lr).Value2
                        R1 = UBound(Arr1)
                    End If
                End If
            Next Ws
        End If
wb.Close
Next File
Set dic = CreateObject("Scripting.Dictionary")
For i = 2 To R
    Key = Arr(i, 1)
        If Not dic.exists(Key) Then
            dic(Key) = i
        Else
            dic(Key) = dic(Key) & "," & i
        End If
Next i
For i = 2 To R1
    Key = Arr1(i, 1)
        If dic.exists(Key) Then
             Arr(dic(Key), 34) = Arr1(i, 12)
        End If
Next i

Set Sh = Sheets("DuLieuTongHop")

    Sh.Range("A1").Resize(10000, UBound(Arr, 2)).ClearContents
    Sh.Range("A1").Resize(R, UBound(Arr, 2)) = Arr
    Sh.Range("A1").Resize(R, UBound(Arr, 2)).EntireColumn.AutoFit

Set dic = Nothing
Set Fso = Nothing
    .ScreenUpdating = True
    .DisplayAlerts = True
    .Calculation = xlCalculationAutomatic
End With
MsgBox "Done"
End Sub

 

[Sonkull]

Mình dùng Power Query ko phải VBA bạn về bỏ 2 file data vào 1 folder rồi thay đường dẫn file Report (mình tô vàng) đến folder bạn vừa tạo nhé mỗi lần thay file data nguồn Refresh all là được

 

[VetMini]

...
Đầu tháng này, bên IT tăng độ khó game,

"raise the bar", Tây con ạ.

Công ty nào mà IT xía vào dữ liệu quản lý vậy? Công việc của IT là phát triển và bảo trì hạ tầng cơ sở của dữ liệu công ty. Cấu trúc và giá trị dữ liệu thuộc về bên quản lý. Nhất là chuyện bán hàng thuộc về dữ liệu quản lý.

 

[acrox84]

Bạn tham khảo :

Option Explicit

Private Sub CommandButton1_Click()
   
    Dim fso As Object, dic As Object
    Dim sheet As Worksheet, wbOpen As Workbook
    Dim arr As Variant
    Dim sFolderName As String, fileName As String
    Dim i As Long, r As Long
    Dim c As Integer
    Dim bFileOpened As Boolean
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    Application.EnableEvents = False
   
    On Error GoTo End_
   
    Set sheet = ThisWorkbook.ActiveSheet
    sFolderName = sheet.Range("C4")
    fileName = sheet.Range("C8")
    Set fso = CreateObject("Scripting.FileSystemObject")
    GoSub checkBook_
   
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(arr, 1) + 1 To UBound(arr, 1)
        dic.Item(arr(i, 1)) = arr(i, 12)
    Next i
    If Not bFileOpened Then wbOpen.Close False
    Set wbOpen = Nothing
    fileName = sheet.Range("C6")
    GoSub checkBook_
    r = UBound(arr, 1): c = UBound(arr, 2) + 1
    ReDim Preserve arr(1 To UBound(arr, 1), 1 To c)
    For i = LBound(arr, 1) + 1 To UBound(arr, 1)
        If dic.Exists(arr(i, 1)) Then
            arr(i, c) = dic.Item(arr(i, 1))
        End If
    Next i
    With wbOpen.Worksheets(1).Range("A1")
        .Resize(r, c) = arr
        .Offset(, c - 1).Resize(r).NumberFormat = "yyyy-mm-dd hh:mm:ss"
    End With
    wbOpen.Save
    If Not bFileOpened Then wbOpen.Close False
    Set wbOpen = Nothing
   
    GoTo End_
   
checkBook_:
    If fso.FileExists(sFolderName & "\" & fileName) Then
        On Error Resume Next
        Set wbOpen = Workbooks(fileName)
        On Error GoTo 0
        If wbOpen Is Nothing Then
            Set wbOpen = Workbooks.Open(sFolderName & "\" & fileName)
            bFileOpened = False
        End If
        arr = wbOpen.Worksheets(1).Range("A1").CurrentRegion.Value
    Else
        MsgBox "Khong tim thay tap tin " & fileName & vbNewLine & _
            " trong thu muc " & sFolderName, vbCritical
        Exit Sub
    End If
   
    Return

End_:

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Application.EnableEvents = True
   
End Sub

Cảm ơn bạn đã dành thời gian làm cho mình file excel thực thi này, mình cảm thấy rất may mắn vì được bạn giúp đỡ, công việc sắp tới mình khỏe hơn nhiều. Giao diện trực quan, dễ cho newbie như mình chỉnh sửa path, tên file,... code chạy mượt rất mau, một lần nữa cảm ơn bạn^^.

Bài đã được tự động gộp: 9/4/23

Mình dùng Power Query ko phải VBA bạn về bỏ 2 file data vào 1 folder rồi thay đường dẫn file Report (mình tô vàng) đến folder bạn vừa tạo nhé mỗi lần thay file data nguồn Refresh all là được

mình xin phép lưu về để dành, trước giờ chưa xài Power Query này nên không biết test ạ, cảm ơn bạn đã hỗ trợ

Bài đã được tự động gộp: 9/4/23

Góp vui.
Bạn tham khảo code này xem sao, hy vọng đúng ý.
Lưu ý đường dẫn của tôi có thể khác của bạn.
Xem file đính kèm và nhấn nút "Chạy code" để có được kết quả.

Option Explicit

Sub ABC()
Dim i&, Lr&, R&, R1&
Dim Arr(), Arr1()
Dim dic As Object, Fso As Object, Key
Dim Ws As Worksheet, Sh As Worksheet, wb As Workbook
Dim File As Variant
Dim Path


With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    .Calculation = xlCalculationManual

Set Fso = CreateObject("Scripting.FileSystemObject")

Path = ActiveWorkbook.Path
On Error Resume Next
    For Each File In Fso.GetFolder(Path).Files
        If File.Name Like "*dulieu*" Then
            Set wb = Workbooks.Open(File)
            For Each Ws In wb.Worksheets
                If Ws.Name Like "Sheet0" Then
                    Lr = Ws.Cells(Rows.Count, 1).End(xlUp).Row
                    If File.Name Like "*dulieu1*" Then
                        Arr = Ws.Range("A1:AH" & Lr).Value2
                        R = UBound(Arr)
                    Else
                        Arr1 = Ws.Range("A2:L" & Lr).Value2
                        R1 = UBound(Arr1)
                    End If
                End If
            Next Ws
        End If
wb.Close
Next File
Set dic = CreateObject("Scripting.Dictionary")
For i = 2 To R
    Key = Arr(i, 1)
        If Not dic.exists(Key) Then
            dic(Key) = i
        Else
            dic(Key) = dic(Key) & "," & i
        End If
Next i
For i = 2 To R1
    Key = Arr1(i, 1)
        If dic.exists(Key) Then
             Arr(dic(Key), 34) = Arr1(i, 12)
        End If
Next i

Set Sh = Sheets("DuLieuTongHop")

    Sh.Range("A1").Resize(10000, UBound(Arr, 2)).ClearContents
    Sh.Range("A1").Resize(R, UBound(Arr, 2)) = Arr
    Sh.Range("A1").Resize(R, UBound(Arr, 2)).EntireColumn.AutoFit

Set dic = Nothing
Set Fso = Nothing
    .ScreenUpdating = True
    .DisplayAlerts = True
    .Calculation = xlCalculationAutomatic
End With
MsgBox "Done"
End Sub

bạn có up nhầm file kết quả không ạ, mình mở file lên không thấy nút "Chạy code" đâu cả. Cảm ơn bạn đã code giúp

 

[HUONGHCKT]

Cảm ơn bạn đã dành thời gian làm cho mình file excel thực thi này, mình cảm thấy rất may mắn vì được bạn giúp đỡ, công việc sắp tới mình khỏe hơn nhiều. Giao diện trực quan, dễ cho newbie như mình chỉnh sửa path, tên file,... code chạy mượt rất mau, một lần nữa cảm ơn bạn^^.

Bài đã được tự động gộp: 9/4/23

mình xin phép lưu về để dành, trước giờ chưa xài Power Query này nên không biết test ạ, cảm ơn bạn đã hỗ trợ

Bài đã được tự động gộp: 9/4/23

bạn có up nhầm file kết quả không ạ, mình mở file lên không thấy nút "Chạy code" đâu cả. Cảm ơn bạn đã code giúp

Xin lỗi up nhầm. Nó đây cơ

 

[acrox84]

Xin lỗi up nhầm. Nó đây cơ

Cảm ơn bạn nhiều, mình thử đúng rôi nè

 

[acrox84]

Bạn tham khảo :

Bạn ơi, phát sinh vấn đề nhỏ liên quan đến Format Cell, mình muốn giữ nguyên định dạng Format ô như file gốc.
Như cột A, cột V mình cần Mã vận đơn hiện full số.
+Cột K, cột S là SĐT thì giữ nguyên số 0 ở đầu.

File gốc tải về đã định dạng phù hợp, vấn đề phát sinh sau khi chạy gộp file, bạn hỗ trợ giúp mình với.

 

[Hoàng Nhật Phương]

Bạn ơi, phát sinh vấn đề nhỏ liên quan đến Format Cell, mình muốn giữ nguyên định dạng Format ô như file gốc.
Như cột A, cột V mình cần Mã vận đơn hiện full số.
+Cột K, cột S là SĐT thì giữ nguyên số 0 ở đầu.

File gốc tải về đã định dạng phù hợp, vấn đề phát sinh sau khi chạy gộp file, bạn hỗ trợ giúp mình với.


View attachment 288709

Bạn thử lại . . :

Option Explicit

Sub getSpeed(ByVal bl As Boolean)
    With Application
        .EnableEvents = Not bl
        .ScreenUpdating = Not bl
        .Calculation = IIf(bl, xlCalculationManual, xlCalculationAutomatic)
    End With
End Sub

Private Sub CommandButton1_Click()
    
    Dim fso As Object, dic As Object
    Dim sheet As Worksheet, wbOpen As Workbook, cell As Range
    Dim arr As Variant, result() As String
    Dim sFolderName As String, fileName As String, capnhat As String
    Dim i As Long, r As Long
    Dim c As Integer
    Dim bFileOpened As Boolean
    capnhat = "C" & ChrW(7853) & "p nh" & ChrW(7853) & "t l" & ChrW(250) & "c:"

    getSpeed True
    
    On Error GoTo End_
    
    Set sheet = ThisWorkbook.ActiveSheet
    sFolderName = sheet.Range("C4")
    fileName = sheet.Range("C8")
    Set fso = CreateObject("Scripting.FileSystemObject")
    GoSub checkBook_
    
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(arr, 1) + 1 To UBound(arr, 1)
        dic.Item(arr(i, 1)) = arr(i, 12)
    Next i
    If Not bFileOpened Then wbOpen.Close False: Set wbOpen = Nothing
    fileName = sheet.Range("C6")
    GoSub checkBook_
    r = UBound(arr, 1): c = UBound(arr, 2)
    ReDim result(1 To UBound(arr, 1), 1 To 1)
    For i = LBound(arr, 1) + 1 To UBound(arr, 1)
        If dic.Exists(arr(i, 1)) Then
            result(i, 1) = dic.Item(arr(i, 1))
        End If
    Next i
    result(1, 1) = capnhat & Format(Now, "yyyy/dd/mm -hh:mm:ss")
    wbOpen.Worksheets(1).Range("A1").Offset(, c).Resize(r) = result
    wbOpen.Save
    If Not bFileOpened Then wbOpen.Close False: Set wbOpen = Nothing
    MsgBox "Xong rùi nha !", vbInformation + vbOKOnly
    GoTo End_
    
checkBook_:
    If fso.FileExists(sFolderName & "\" & fileName) Then
        On Error Resume Next
        Set wbOpen = Workbooks(fileName)
        On Error GoTo 0
        If wbOpen Is Nothing Then
            Set wbOpen = Workbooks.Open(sFolderName & "\" & fileName)
            bFileOpened = False
        End If
        arr = wbOpen.Worksheets(1).Range("A1").CurrentRegion.Value2
    Else
        MsgBox "Khong tim thay tap tin " & fileName & vbNewLine & _
            " trong thu muc " & sFolderName, vbCritical
        GoTo End_
    End If
    Return

End_:
    getSpeed False
    
End Sub

 

[Hoàng Nhật Phương]

Bạn thử lại . . :

Option Explicit

Sub getSpeed(ByVal bl As Boolean)
    With Application
        .EnableEvents = Not bl
        .ScreenUpdating = Not bl
        .Calculation = IIf(bl, xlCalculationManual, xlCalculationAutomatic)
    End With
End Sub

Private Sub CommandButton1_Click()
   
    Dim fso As Object, dic As Object
    Dim sheet As Worksheet, wbOpen As Workbook, cell As Range
    Dim arr As Variant, result() As String
    Dim sFolderName As String, fileName As String, capnhat As String
    Dim i As Long, r As Long
    Dim c As Integer
    Dim bFileOpened As Boolean
    capnhat = "C" & ChrW(7853) & "p nh" & ChrW(7853) & "t l" & ChrW(250) & "c:"

    getSpeed True
   
    On Error GoTo End_
   
    Set sheet = ThisWorkbook.ActiveSheet
    sFolderName = sheet.Range("C4")
    fileName = sheet.Range("C8")
    Set fso = CreateObject("Scripting.FileSystemObject")
    GoSub checkBook_
   
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(arr, 1) + 1 To UBound(arr, 1)
        dic.Item(arr(i, 1)) = arr(i, 12)
    Next i
    If Not bFileOpened Then wbOpen.Close False: Set wbOpen = Nothing
    fileName = sheet.Range("C6")
    GoSub checkBook_
    r = UBound(arr, 1): c = UBound(arr, 2)
    ReDim result(1 To UBound(arr, 1), 1 To 1)
    For i = LBound(arr, 1) + 1 To UBound(arr, 1)
        If dic.Exists(arr(i, 1)) Then
            result(i, 1) = dic.Item(arr(i, 1))
        End If
    Next i
    result(1, 1) = capnhat & Format(Now, "yyyy/dd/mm -hh:mm:ss")
    wbOpen.Worksheets(1).Range("A1").Offset(, c).Resize(r) = result
    wbOpen.Save
    If Not bFileOpened Then wbOpen.Close False: Set wbOpen = Nothing
    MsgBox "Xong rùi nha !", vbInformation + vbOKOnly
    GoTo End_
   
checkBook_:
    If fso.FileExists(sFolderName & "\" & fileName) Then
        On Error Resume Next
        Set wbOpen = Workbooks(fileName)
        On Error GoTo 0
        If wbOpen Is Nothing Then
            Set wbOpen = Workbooks.Open(sFolderName & "\" & fileName)
            bFileOpened = False
        End If
        arr = wbOpen.Worksheets(1).Range("A1").CurrentRegion.Value2
    Else
        MsgBox "Khong tim thay tap tin " & fileName & vbNewLine & _
            " trong thu muc " & sFolderName, vbCritical
        GoTo End_
    End If
    Return

End_:
    getSpeed False
   
End Sub

Với code trên mình sửa lại:
Nếu file mới chưa cập nhật lần nào kết quả sẽ đưa vào cột AH, nếu cập nhật lần tiếp theo (không phải file mới) kết quả sẽ đưa vào cột AI. tại dòng đầu mỗi lần cập nhật cũng sẽ ghi thời điểm cập nhật nhé bạn.

 

[acrox84]

Với code trên mình sửa lại:
Nếu file mới chưa cập nhật lần nào kết quả sẽ đưa vào cột AH, nếu cập nhật lần tiếp theo (không phải file mới) kết quả sẽ đưa vào cột AI. tại dòng đầu mỗi lần cập nhật cũng sẽ ghi thời điểm cập nhật nhé bạn.

chuẩn rồi bạn, tối nay mình mới thử xong, quá đã thanksyou!

 

[acrox84]

Option Explicit

_Phiền bạn chút, công việc cuối ngày mình là tổng hợp đơn, phân loại rồi gửi khách kiểm tra lại. Mình có 2 tài khoản đổ file ra, trước đây nó xuất ra theo thứ tự cột giống hệt nhau nên mình Copy tay hết dòng dữ liệu rồi Paste ra là xong.

Giờ không hiểu sao Tài khoản 2 đổ ra thứ tự khác nhiều cột so với Tài khoản 1, mình tìm cách chỉnh cài đặt các thứ vẫn không được, cài lại trình duyệt Chorme, Firefox, Edge các thứ cũng không được.

_Mình nhớ tới bạn từng giúp thiết kế file chức năng gộp tương tự nên lại lên nhờ vả, mong bạn giúp thêm 1 file gộp này.

*Mình cần chép toàn bộ data file dulieu2 sang dulieu, mỗi file có thể tối đa 1000 dòng. Các tiêu đề 2 file đều giống hệt nhau, chỉ có thứ tự sắp xếp là khác (cái thứ tự khác này là cố định, chứ không phải mỗi lần đổ file ra là random)

*File gốc dulieu làm chuẩn, chép thêm dulieu2 qua là xong (trong file đính kèm là từ dòng 41, chép thêm 5 dòng nữa, cần đúng cột & định dạng ô)
Chân Thành Cảm Ơn!!

 

[Hoàng Nhật Phương]

_Phiền bạn chút, công việc cuối ngày mình là tổng hợp đơn, phân loại rồi gửi khách kiểm tra lại. Mình có 2 tài khoản đổ file ra, trước đây nó xuất ra theo thứ tự cột giống hệt nhau nên mình Copy tay hết dòng dữ liệu rồi Paste ra là xong.

Giờ không hiểu sao Tài khoản 2 đổ ra thứ tự khác nhiều cột so với Tài khoản 1, mình tìm cách chỉnh cài đặt các thứ vẫn không được, cài lại trình duyệt Chorme, Firefox, Edge các thứ cũng không được.

_Mình nhớ tới bạn từng giúp thiết kế file chức năng gộp tương tự nên lại lên nhờ vả, mong bạn giúp thêm 1 file gộp này.

*Mình cần chép toàn bộ data file dulieu2 sang dulieu, mỗi file có thể tối đa 1000 dòng. Các tiêu đề 2 file đều giống hệt nhau, chỉ có thứ tự sắp xếp là khác (cái thứ tự khác này là cố định, chứ không phải mỗi lần đổ file ra là random)

*File gốc dulieu làm chuẩn, chép thêm dulieu2 qua là xong (trong file đính kèm là từ dòng 41, chép thêm 5 dòng nữa, cần đúng cột & định dạng ô)
Chân Thành Cảm Ơn!!

Mình đọc nhưng chưa hiểu ý bạn.
Có phải vấn đề lần này không giống vấn đề lần trước.

Các tiêu đề 2 file đều giống hệt nhau,

Mình có thấy giống đâu nhỉ:



Nếu chỉ là :

cần chép toàn bộ data file dulieu2 sang dulieu

Thì điều kiện để copy đưa sang là thế nào vậy bạn , có so sánh những cột nào giống nhau rồi thì đưa sang nữa không?

 

[acrox84]

Mình đọc nhưng chưa hiểu ý bạn.
Có phải vấn đề lần này không giống vấn đề lần trước.

Mình có thấy giống đâu nhỉ:

View attachment 290228

Nếu chỉ là :

Thì điều kiện để copy đưa sang là thế nào vậy bạn , có so sánh những cột nào giống nhau rồi thì đưa sang nữa không?

Đúng rồi bạn, so sánh tiêu đề cột giống nhau thì copy sang, lấy file dulieu.xlsx làm gốc
--> 2 file này có 33 cột dữ liệu có tiêu đề hoàn toàn giống nhau, nhưng thứ tự sắp xếp khác nhau, nên mình không copy & paste bình thường được.

 

[Hoàng Nhật Phương]

Đúng rồi bạn, so sánh tiêu đề cột giống nhau thì copy sang, lấy file dulieu.xlsx làm gốc
--> 2 file này có 33 cột dữ liệu có tiêu đề hoàn toàn giống nhau, nhưng thứ tự sắp xếp khác nhau, nên mình không copy & paste bình thường được.

Chào bạn, có nhiều cô giống nhau ở 2 file nhưng thứ tự khác nhau và copy các cột giống nhau thì mình hiểu.
Vấn đề là điều kiện copy là như thế nào ví dụ trùng mã đơn hàng thì thôi không copy nữa hoặc trùng mã nhưng dữ liệu cột khác mà khác thì copy v.v... hay là trùng rồi thì cứ copy tiếp chèn xuống dưới?

 

[acrox84]

Chào bạn, có nhiều cô giống nhau ở 2 file nhưng thứ tự khác nhau và copy các cột giống nhau thì mình hiểu.
Vấn đề là điều kiện copy là như thế nào ví dụ trùng mã đơn hàng thì thôi không copy nữa hoặc trùng mã nhưng dữ liệu cột khác mà khác thì copy v.v... hay là trùng rồi thì cứ copy tiếp chèn xuống dưới?

Kiểu gộp dữ liệu 2 file lại thành một, sau đó mình lấy file dulieu.xlsx này xử lý tiếp.
Bạn xem clip mô tả này giúp mình. Trước đây 2 file này cùng thứ tự cột thì mình hay copy - paste như vậy rồi save file dulieu.xlsx lại là xong. Giờ file dulieu2 này đảo lộn thứ tự cột nên mình không làm được như vậy nữa.

Liên kết: https://www.youtube.com/watch?v=_JkkXf8s6T8

 

[ngocbaovu]

Kiểu gộp dữ liệu 2 file lại thành một, sau đó mình lấy file dulieu.xlsx này xử lý tiếp.

Việc copy sắp xếp lại dữ liệu theo form file dulieu thì không vấn đề gì. Có điều là có cần kiểm tra "Mã vận đơn" trong file dulieu2 đã tồn tại trong file dulieu chưa? Nếu đã có thì có copy không? nếu copy thì có xử lý dữ liệu đã tồn tại trong file dulieu không?

 

[acrox84]

Việc copy sắp xếp lại dữ liệu theo form file dulieu thì không vấn đề gì. Có điều là có cần kiểm tra "Mã vận đơn" trong file dulieu2 đã tồn tại trong file dulieu chưa? Nếu đã có thì có copy không? nếu copy thì có xử lý dữ liệu đã tồn tại trong file dulieu không?

Không phải kiểm tra ạ, do 2 file này độc lập nhau, là 2 tài khoản của 2 khách hàng khác nhau lên đơn nên mã vận đơn các thứ khác nhau hoàn toàn.
Do cuối ngày phải gộp toàn bộ dữ liệu lại để kế toán tính xem được bao nhiêu đơn, thu bao nhiêu tiền tổng cộng,...

 

[Hoàng Nhật Phương]

Không phải kiểm tra ạ, do 2 file này độc lập nhau, là 2 tài khoản của 2 khách hàng khác nhau lên đơn nên mã vận đơn các thứ khác nhau hoàn toàn.
Do cuối ngày phải gộp toàn bộ dữ liệu lại để kế toán tính xem được bao nhiêu đơn, thu bao nhiêu tiền tổng cộng,...

Option Explicit

Sub getSpeed(ByVal bl As Boolean)
    With Application
        .EnableEvents = Not bl
        .ScreenUpdating = Not bl
        .Calculation = IIf(bl, xlCalculationManual, xlCalculationAutomatic)
    End With
End Sub

Private Sub CommandButton1_Click()
    
    Dim wbA As Workbook, wbB As Workbook, wsA As Worksheet, wsB As Worksheet, colA As Range, colB As Range
    Dim lastRowA As Long, lastRowB As Long, lastColA As Long, lastColB As Long
    Dim colTitleA As String, colTitleB As String, sFileNameA As String, sFileNameB As String
    
    getSpeed True
    
    On Error GoTo End_
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    sFileNameA = Me.Range("C4").Value & "\" & Me.Range("C6").Value
    sFileNameB = Me.Range("C4").Value & "\" & Me.Range("C8").Value
    If (Not fso.FileExists(sFileNameA)) Or (Not fso.FileExists(sFileNameA)) Then
        MsgBox "Khong tim thay tap tin trong thu muc chi dinh.", vbCritical
        GoTo End_
    End If
    
    Set wbA = Workbooks.Open(sFileNameA):   Set wsA = wbA.Worksheets(1)
    Set wbB = Workbooks.Open(sFileNameB):   Set wsB = wbB.Worksheets(1)
    
    lastRowA = wsA.Cells(wsA.Rows.Count, 1).End(xlUp).Row
    lastColA = wsA.Cells(1, wsA.Columns.Count).End(xlToLeft).Column
    lastRowB = wsB.Cells(wsB.Rows.Count, 1).End(xlUp).Row
    lastColB = wsB.Cells(1, wsB.Columns.Count).End(xlToLeft).Column
    
    For Each colB In wsB.Range(wsB.Cells(1, 1), wsB.Cells(1, lastColB)).Columns
        colTitleB = colB.Cells(1).Value
        Set colA = wsA.Rows(1).Find(colTitleB, LookIn:=xlValues, LookAt:=xlWhole)
        If Not colA Is Nothing Then
            lastRowA = wsA.Cells(wsA.Rows.Count, colA.Column).End(xlUp).Row
            wsB.Range(colB.Cells(2), colB.Cells(lastRowB)).Copy _
                Destination:=wsA.Cells(lastRowA + 1, colA.Column)
        End If
    Next colB
    
    wbB.Close SaveChanges:=False
    wbA.Save:   wbA.Close SaveChanges:=False
    
    MsgBox "Xong rùi nha !", vbInformation + vbOKOnly

End_:
    getSpeed False
    
End Sub

Bạn chạy chức năng trong sheet2 rồi kiểm tra lại.
Mỗi lần chạy chức năng là dữ liệu lại copy tiếp xuống dưới không xác định trùng lặp.