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

Liên hệ QC
Tôi tuân thủ nội quy khi đăng bài
Có
A

acrox84

Thành viên hoạt động
Tham gia
22/3/08
Bài viết
101
Được thích
28
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:
2023-04-07 20-54-13.jpg

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ẻ ^^!
 

File đính kèm

  • dulieu1.xlsx
    21.3 KB · Đọc: 28
  • dulieu2.xlsx
    19.3 KB · Đọc: 24
Giải pháp
Hoàng Nhật Phương
acrox84 đã viết:
Cái chức năng tạo thêm thư mục backup file mình chưa cần.
Nếu có thể, bạn sửa lại ntn mà không chép đè lên file dulieu thì mình có thể kiểm tra lại nguồn dulieu1 và dulieu2.
Tức là cùng thư mục có dulieu1 và dulieu2, bấm nút chạy code VBA sẽ ra file mới dulieu.xlsx và không xóa dulieu1 và dulieu2.
Cảm ơn bạn rất nhiều!

View attachment 290261
Nhấp chuột vào đây để mở rộng...
Bạn chạy chức năng trong sheet3:
Mã: 
Option Explicit

Private Sub CommandButton1_Click()

    Dim wb As Workbook, wbNew As Workbook, ws As Worksheet, wsNew As Worksheet, col As Range, colNew As Range
    Dim lastRow As Long, lastCol As Long, lastRowNew As Long
    Dim colTitle As String, sFolder As String, newFileName As String, filePath As String
    Dim fso As Object, fileNames As Variant, fileName...
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Hoàng Nhật Phương đã viết:
Mã: 
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.
Nhấp chuột vào đây để mở rộng...
Done!
Cảm ơn bạn lần nữa đã giải quyết vấn đề giúp mình, mình mới tets thử rất hoàn chỉnh và chính xác.
 
Upvote 0
acrox84 đã viết:
Done!
Cảm ơn bạn lần nữa đã giải quyết vấn đề giúp mình, mình mới tets thử rất hoàn chỉnh và chính xác.
Nhấp chuột vào đây để mở rộng...
Bạn,thử lại đoạn này để giảm rủi do trùng lặp do bấm nhầm vậy.
Mình đã tạo thêm 1 thư mục "copy_OK" để lưu dữ liệu nguồn,sau khi đã thực hiện chuyển dữ liệu sang:
Mã: 
Option Explicit

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
    Dim sErr As String, copyFolderPath As String, sFolder As String, newFileName As String
    Dim fso As Object, dataExists As Boolean

    Set fso = CreateObject("Scripting.FileSystemObject")
    sFolder = Me.Range("C4").Value
    If Not fso.FolderExists(sFolder) Then
        MsgBox "Khong tim thay thu muc: " & vbNewLine & sFolder, vbCritical
        GoTo End_
    End If
    
    sFileNameA = sFolder & "\" & Me.Range("C6").Value
    sFileNameB = sFolder & "\" & Me.Range("C8").Value
    
    If Not fso.FileExists(sFileNameA) Then sErr = sFileNameA
    If Not fso.FileExists(sFileNameB) Then sErr = sFileNameB
    
    If Len(sErr) > 0 Then
        MsgBox "Khong tim thay tap tin: " & vbNewLine & sErr, 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
            dataExists = Not IsError(Application.Match(colB.Cells(2).Value, wsA.Range(colA.Offset(1), wsA.Cells(lastRowA, colA.Column)), 0))
            If Not dataExists 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
        End If
    Next colB
    
    wbB.Close SaveChanges:=False:   wbA.Save:   wbA.Close SaveChanges:=False
    copyFolderPath = sFolder & "\copy_OK"
    If Not fso.FolderExists(copyFolderPath) Then fso.CreateFolder copyFolderPath
    
    If fso.FolderExists(copyFolderPath) Then
        newFileName = "copy__OK__" & Format(Now, "yymmddhhmmss") & ".xlsx"
        fso.MoveFile sFileNameB, copyFolderPath & "\" & newFileName
    End If

End_:
    getSpeed False

End Sub
 

File đính kèm

  • Tool.xlsm
    40.1 KB · Đọc: 9
Lần chỉnh sửa cuối:
Upvote 0
Hoàng Nhật Phương đã viết:
Bạn,thử lại đoạn này để giảm rủi do trùng lặp do bấm nhầm vậy.
Mình đã tạo thêm 1 thư mục "copy_OK" để lưu dữ liệu nguồn,sau khi đã thực hiện chuyển dữ liệu sang:
Mã: 
Option Explicit

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
    Dim sErr As String, copyFolderPath As String, sFolder As String, newFileName As String
    Dim fso As Object, dataExists As Boolean

    Set fso = CreateObject("Scripting.FileSystemObject")
    sFolder = Me.Range("C4").Value
    If Not fso.FolderExists(sFolder) Then
        MsgBox "Khong tim thay thu muc: " & vbNewLine & sFolder, vbCritical
        GoTo End_
    End If
   
    sFileNameA = sFolder & "\" & Me.Range("C6").Value
    sFileNameB = sFolder & "\" & Me.Range("C8").Value
   
    If Not fso.FileExists(sFileNameA) Then sErr = sFileNameA
    If Not fso.FileExists(sFileNameB) Then sErr = sFileNameB
   
    If Len(sErr) > 0 Then
        MsgBox "Khong tim thay tap tin: " & vbNewLine & sErr, 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
            dataExists = Not IsError(Application.Match(colB.Cells(2).Value, wsA.Range(colA.Offset(1), wsA.Cells(lastRowA, colA.Column)), 0))
            If Not dataExists 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
        End If
    Next colB
   
    wbB.Close SaveChanges:=False:   wbA.Save:   wbA.Close SaveChanges:=False
    copyFolderPath = sFolder & "\copy_OK"
    If Not fso.FolderExists(copyFolderPath) Then fso.CreateFolder copyFolderPath
   
    If fso.FolderExists(copyFolderPath) Then
        newFileName = "copy__OK__" & Format(Now, "yymmddhhmmss") & ".xlsx"
        fso.MoveFile sFileNameB, copyFolderPath & "\" & newFileName
    End If

End_:
    getSpeed False

End Sub
Nhấp chuột vào đây để mở rộng...
Mình thử gộp thêm vài loại file excel có nhiều cột khác nhau, thì file VBA của bạn đều gộp dữ liệu tốt, tính ứng dụng cho nhiều mục đích của những bạn khác cũng xài lại đc, không riêng gì mình.
Cho hỏi bài này có giới hạn bao nhiêu dòng dữ liệu ở mỗi file không ạ
 
Upvote 0
Hoàng Nhật Phương đã viết:
Bạn,thử lại đoạn này để giảm rủi do trùng lặp do bấm nhầm vậy.
Mình đã tạo thêm 1 thư mục "copy_OK" để lưu dữ liệu nguồn,sau khi đã thực hiện chuyển dữ liệu sang:
Nhấp chuột vào đây để mở rộng...
Cái chức năng tạo thêm thư mục backup file mình chưa cần.
Nếu có thể, bạn sửa lại ntn mà không chép đè lên file dulieu thì mình có thể kiểm tra lại nguồn dulieu1 và dulieu2.
Tức là cùng thư mục có dulieu1 và dulieu2, bấm nút chạy code VBA sẽ ra file mới dulieu.xlsx và không xóa dulieu1 và dulieu2.
Cảm ơn bạn rất nhiều!

1684302886120.png
 
Upvote 0
acrox84 đã viết:
Cái chức năng tạo thêm thư mục backup file mình chưa cần.
Nếu có thể, bạn sửa lại ntn mà không chép đè lên file dulieu thì mình có thể kiểm tra lại nguồn dulieu1 và dulieu2.
Tức là cùng thư mục có dulieu1 và dulieu2, bấm nút chạy code VBA sẽ ra file mới dulieu.xlsx và không xóa dulieu1 và dulieu2.
Cảm ơn bạn rất nhiều!

View attachment 290261
Nhấp chuột vào đây để mở rộng...
Bạn chạy chức năng trong sheet3:
Mã: 
Option Explicit

Private Sub CommandButton1_Click()

    Dim wb As Workbook, wbNew As Workbook, ws As Worksheet, wsNew As Worksheet, col As Range, colNew As Range
    Dim lastRow As Long, lastCol As Long, lastRowNew As Long
    Dim colTitle As String, sFolder As String, newFileName As String, filePath As String
    Dim fso As Object, fileNames As Variant, fileName As Variant
    
    getSpeed True
    On Error GoTo End_
    Set fso = CreateObject("Scripting.FileSystemObject")
    sFolder = Me.Range("C4").Value
    
    If Not fso.FolderExists(sFolder) Then
        MsgBox "Khong tim thay thu muc: " & vbNewLine & sFolder, vbCritical
        GoTo End_
    End If
    fileNames = Split(Me.Range("C6").Value, ";")
    Set wbNew = Workbooks.Add:  Set wsNew = wbNew.Worksheets(1)
    lastRowNew = 1
    For Each fileName In fileNames
        filePath = sFolder & "\" & fileName
        If Not fso.FileExists(filePath) Then
            MsgBox "Khong tim thay tap tin: " & vbNewLine & filePath, vbCritical
            GoTo End_
        End If
        Set wb = Workbooks.Open(filePath):  Set ws = wb.Worksheets(1)
        lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
        lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
        If lastRowNew = 1 Then
            ws.UsedRange.Copy Destination:=wsNew.Cells(lastRowNew, 1)
            lastRowNew = lastRow
        Else
            For Each col In ws.Range(ws.Cells(1, 1), ws.Cells(1, lastCol))
                colTitle = col.Cells(1).Value
                Set colNew = wsNew.Rows(1).Find(colTitle, LookIn:=xlValues, LookAt:=xlWhole)
                If Not colNew Is Nothing Then
                    ws.Range(col.Cells(2), col.Cells(lastRow)).Copy Destination:=wsNew.Cells(wsNew.Cells(wsNew.Rows.Count, colNew.Column).End(xlUp).Row + 1, colNew.Column)
                End If
            Next col
            lastRowNew = lastRowNew + lastRow - 1
        End If
        wb.Close SaveChanges:=False
    Next fileName
    
    newFileName = "merged_data_" & Format(Now, "yyyyMMdd_hhmmss") & ".xlsx"
    wbNew.SaveAs sFolder & "\" & newFileName
    wbNew.Close SaveChanges:=False
    MsgBox "Xong rùi nha, file moi duoc luu toi :" & vbNewLine & sFolder & "\" & newFileName, vbInformation

End_:
    getSpeed False
    
End Sub

acrox84 đã viết:
Mình thử gộp thêm vài loại file excel có nhiều cột khác nhau, thì file VBA của bạn đều gộp dữ liệu tốt, tính ứng dụng cho nhiều mục đích của những bạn khác cũng xài lại đc, không riêng gì mình.
Cho hỏi bài này có giới hạn bao nhiêu dòng dữ liệu ở mỗi file không ạ
Nhấp chuột vào đây để mở rộng...
Hihi tất nhiên là có chứ bạn, excel của bạn có bao nhiêu dòng bao nhiêu cột thì code giới hạn chừng đó.
 

File đính kèm

  • Tool.xlsm
    49.4 KB · Đọc: 11
Lần chỉnh sửa cuối:
Upvote 0
Giải pháp
Hoàng Nhật Phương đã viết:
Bạn chạy chức năng trong sheet3:
Mã: 
Option Explicit

Private Sub CommandButton1_Click()

    Dim wb As Workbook, wbNew As Workbook, ws As Worksheet, wsNew As Worksheet, col As Range, colNew As Range
    Dim lastRow As Long, lastCol As Long, lastRowNew As Long
    Dim colTitle As String, sFolder As String, newFileName As String, filePath As String
    Dim fso As Object, fileNames As Variant, fileName As Variant
   
    getSpeed True
    On Error GoTo End_
   
    Set fso = CreateObject("Scripting.FileSystemObject")
    sFolder = Me.Range("C4").Value
    If Not fso.FolderExists(sFolder) Then
        MsgBox "Khong tim thay thu muc: " & vbNewLine & sFolder, vbCritical
        GoTo End_
    End If
    fileNames = Split(Me.Range("C6").Value, ";")
    Set wbNew = Workbooks.Add:  Set wsNew = wbNew.Worksheets(1)
    lastRowNew = 1
   
    For Each fileName In fileNames
        filePath = sFolder & "\" & fileName
        If Not fso.FileExists(filePath) Then
            MsgBox "Khong tim thay tap tin: " & vbNewLine & filePath, vbCritical
            GoTo End_
        End If
        Set wb = Workbooks.Open(filePath):  Set ws = wb.Worksheets(1)
        lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
        lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
        ws.Range("A1").CurrentRegion.Copy Destination:=wsNew.Cells(lastRowNew, 1)
        lastRowNew = lastRowNew + lastRow
        wb.Close SaveChanges:=False
    Next fileName
   
    newFileName = "merged_data_" & Format(Now, "yyyyMMdd_hhmmss") & ".xlsx"
    wbNew.SaveAs sFolder & "\" & newFileName
    wbNew.Close SaveChanges:=False
    MsgBox "Xong rùi nha, file moi duoc luu toi :" & vbNewLine & sFolder & "\" & newFileName, vbInformation

End_:
    getSpeed False
   
End Sub


Hihi tất nhiên là có chứ bạn, excel của bạn có bao nhiêu dòng bao nhiêu cột thì code giới hạn chừng đó.
Nhấp chuột vào đây để mở rộng...
Tools này có chức năng gộp cơ bản, mà không có yêu cầu như tool ở sheet 2 của mình.
Mình vẫn cần chức năng giữ nguyên form cột ở file đầu tiên (trường hợp này tên cố định là dulieu1) và bỏ dòng tiêu đề khi gộp.

1684329248777.png
 
Upvote 0
acrox84 đã viết:
Tools này có chức năng gộp cơ bản, mà không có yêu cầu như tool ở sheet 2 của mình.
Mình vẫn cần chức năng giữ nguyên form cột ở file đầu tiên (trường hợp này tên cố định là dulieu1) và bỏ dòng tiêu đề khi gộp.

View attachment 290288
Nhấp chuột vào đây để mở rộng...
Xin lỗi, khi nãy sửa code để rút gọn mình xóa hơi quá tay vì không nghĩ đến vấn đề 2 file có dữ liệu các cột khác nhau.
Mình đã sửa lại code bài trên (bài 25) và đính kèm lại file.
Bạn kiểm tra lại.
 
Upvote 0
Hoàng Nhật Phương đã viết:
Xin lỗi, khi nãy sửa code để rút gọn mình xóa hơi quá tay vì không nghĩ đến vấn đề 2 file có dữ liệu các cột khác nhau.
Mình đã sửa lại code bài trên (bài 25) và đính kèm lại file.
Bạn kiểm tra lại.
Nhấp chuột vào đây để mở rộng...
Hoàn thiện toàn bộ nhu cầu của mình rồi, nãy giờ mãi mê thử file Tools mới này.
Cảm ơn bạn Hoàng Nhật Phương rất rất nhiều, với Tools bạn viết mỗi ngày mình sẽ đều sử dụng, nó giúp mình tiết kiệm thời gian và yên tâm không sợ sai sót khi copy tay bị nhầm nữa!
 
Upvote 0
Hoàng Nhật Phương đã viết:
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
Dim i As Long, r As Long
Dim c As Integer
Dim bFileOpened As Boolean

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
wbOpen.Worksheets(1).Range("A1").Offset(, c).Resize(r) = result
wbOpen.Save
If Not bFileOpened Then wbOpen.Close False: Set wbOpen = Nothing
MsgBox "BC MINH: Ghep KyNhan xong!", 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
Nhấp chuột vào đây để mở rộng...
Bạn Hoàng Nhật Phương giúp mình chỉnh code file này lại với, code này lúc trước bạn viết giúp:
+Đối chiếu cột Mã vận đơn (cột có thứ tự là 1) để ghép cột Thời gian ký nhận (cột có thứ tự là 12)
-->giờ cột Mã vận đơn đổi ở vị trí thứ tự là 2 thì mình sửa code trên ở những chỗ nào vậy?

+Bạn giúp mình Bổ sung thêm: Cũng điều kiện trên, dựa trên cột Mã vận đơn có số thứ tự cột là 2, đồng thời chép cột Thời gian ký nhận (số cột 12) và chép thêm cột Tỉnh (số cột 19)

*Chân thành cảm ơn bạn rất nhiều!
 
Upvote 0
acrox84 đã viết:
Bạn Hoàng Nhật Phương giúp mình chỉnh code file này lại với, code này lúc trước bạn viết giúp:
+Đối chiếu cột Mã vận đơn (cột có thứ tự là 1) để ghép cột Thời gian ký nhận (cột có thứ tự là 12)
-->giờ cột Mã vận đơn đổi ở vị trí thứ tự là 2 thì mình sửa code trên ở những chỗ nào vậy?

+Bạn giúp mình Bổ sung thêm: Cũng điều kiện trên, dựa trên cột Mã vận đơn có số thứ tự cột là 2, đồng thời chép cột Thời gian ký nhận (số cột 12) và chép thêm cột Tỉnh (số cột 19)

*Chân thành cảm ơn bạn rất nhiều!
Nhấp chuột vào đây để mở rộng...
Bạn gửi lại file kèm , mình coi lại xem thế nào ạ.
Mà bạn đang sử dụng chức năng trong sheet nào của file bài 25 nhỉ?
 
Upvote 0

File đính kèm

  • dulieu.xls
    31.5 KB · Đọc: 5
  • Ghep NgayGiao.xlsm
    25.4 KB · Đọc: 5
  • ngaygiao.xlsx
    10.8 KB · Đọc: 4
Upvote 0
acrox84 đã viết:
mình gửi đính kèm lại file Ghep NgayGiao và 2 file dữ liệu.
Nhấp chuột vào đây để mở rộng...
Bạn tìm và thay thế bằng sub này nhé:
Mã: 
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, sTinhThanh As String
    Dim MaVanDon As Variant, ThoiGianKyNhan As Variant
    Dim i As Long, r As Long
    Dim c As Integer
    Dim bFileOpened As Boolean
    
    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)
        MaVanDon = arr(i, 1)        'Ma Van don file nguon
        ThoiGianKyNhan = arr(i, 12) 'Thoi gian ky nhan
        sTinhThanh = arr(i, 19)     'Tinh Thanh
        dic.Item(MaVanDon) = Array(ThoiGianKyNhan, sTinhThanh)
    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 2)
    For i = LBound(arr, 1) + 1 To UBound(arr, 1)
        MaVanDon = arr(i, 2) 'Ma Van Don file ket qua
        If dic.Exists(MaVanDon) Then
            result(i, 1) = dic.Item(MaVanDon)(0)
            result(i, 2) = dic.Item(MaVanDon)(1)
        End If
    Next i
    wbOpen.Worksheets(1).Range("A1").Offset(, c).Resize(r, 2) = result
    wbOpen.Save
    If Not bFileOpened Then wbOpen.Close False: Set wbOpen = Nothing
    MsgBox "BC MINH: Ghep KyNhan xong!", 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
 
Upvote 0
Hoàng Nhật Phương đã viết:
Bạn tìm và thay thế bằng sub này nhé:
Mã: 
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, sTinhThanh As String
    Dim MaVanDon As Variant, ThoiGianKyNhan As Variant
    Dim i As Long, r As Long
    Dim c As Integer
    Dim bFileOpened As Boolean
   
    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)
        MaVanDon = arr(i, 1)        'Ma Van don file nguon
        ThoiGianKyNhan = arr(i, 12) 'Thoi gian ky nhan
        sTinhThanh = arr(i, 19)     'Tinh Thanh
        dic.Item(MaVanDon) = Array(ThoiGianKyNhan, sTinhThanh)
    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 2)
    For i = LBound(arr, 1) + 1 To UBound(arr, 1)
        MaVanDon = arr(i, 2) 'Ma Van Don file ket qua
        If dic.Exists(MaVanDon) Then
            result(i, 1) = dic.Item(MaVanDon)(0)
            result(i, 2) = dic.Item(MaVanDon)(1)
        End If
    Next i
    wbOpen.Worksheets(1).Range("A1").Offset(, c).Resize(r, 2) = result
    wbOpen.Save
    If Not bFileOpened Then wbOpen.Close False: Set wbOpen = Nothing
    MsgBox "BC MINH: Ghep KyNhan xong!", 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
Nhấp chuột vào đây để mở rộng...
Ghép ngon lành 2 cột mới theo điều kiện trùng mã vận đơn rồi bạn, cảm ơn rất rất nhiều :D
 
Upvote 0
Hoàng Nhật Phương đã viết:
Bạn tìm và thay thế bằng sub này nhé:
Mã: 
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, sTinhThanh As String
    Dim MaVanDon As Variant, ThoiGianKyNhan As Variant
    Dim i As Long, r As Long
    Dim c As Integer
    Dim bFileOpened As Boolean
   
    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)
        MaVanDon = arr(i, 1)        'Ma Van don file nguon
        ThoiGianKyNhan = arr(i, 12) 'Thoi gian ky nhan
        sTinhThanh = arr(i, 19)     'Tinh Thanh
        dic.Item(MaVanDon) = Array(ThoiGianKyNhan, sTinhThanh)
    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 2)
    For i = LBound(arr, 1) + 1 To UBound(arr, 1)
        MaVanDon = arr(i, 2) 'Ma Van Don file ket qua
        If dic.Exists(MaVanDon) Then
            result(i, 1) = dic.Item(MaVanDon)(0)
            result(i, 2) = dic.Item(MaVanDon)(1)
        End If
    Next i
    wbOpen.Worksheets(1).Range("A1").Offset(, c).Resize(r, 2) = result
    wbOpen.Save
    If Not bFileOpened Then wbOpen.Close False: Set wbOpen = Nothing
    MsgBox "BC MINH: Ghep KyNhan xong!", 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
Nhấp chuột vào đây để mở rộng...
Cho mình hỏi thêm, trường hợp MVĐ ở 2 cột thứ tự khác nhau giữa file nguồn và file đích thì điều chỉnh code này như thế nào ạ
Ví dụ: file Nguồn, MVĐ ở cột thứ 1 & file Đích, MVĐ ở cột thứ 2.

Mình thử vọc code trên của bạn, có thấy chép dữ liệu qua và hiện ra số 0 hoặc N/A hoặc số -60000 đều sai, như hình:
1687568405532.png
 
Upvote 0
acrox84 đã viết:
Cho mình hỏi thêm, trường hợp MVĐ ở 2 cột thứ tự khác nhau giữa file nguồn và file đích thì điều chỉnh code này như thế nào ạ
Ví dụ: file Nguồn, MVĐ ở cột thứ 1 & file Đích, MVĐ ở cột thứ 2.

Mình thử vọc code trên của bạn, có thấy chép dữ liệu qua và hiện ra số 0 hoặc N/A hoặc số -60000 đều sai, như hình:
View attachment 291874
Nhấp chuột vào đây để mở rộng...
Code bài 32 mình đã có chú thích rồi mà bạn:
Mã: 
    For i = LBound(arr, 1) + 1 To UBound(arr, 1)
        MaVanDon = arr(i, 1)        'Ma Van don file nguon
        ThoiGianKyNhan = arr(i, 12) 'Thoi gian ky nhan
        sTinhThanh = arr(i, 19)     'Tinh Thanh
        dic.Item(MaVanDon) = Array(ThoiGianKyNhan, sTinhThanh)
    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 2)
    For i = LBound(arr, 1) + 1 To UBound(arr, 1)
        MaVanDon = arr(i, 2) 'Ma Van Don file ket qua
        If dic.Exists(MaVanDon) Then
            result(i, 1) = dic.Item(MaVanDon)(0)
            result(i, 2) = dic.Item(MaVanDon)(1)
        End If
    Next i
 
Upvote 0
Hoàng Nhật Phương đã viết:
Code bài 32 mình đã có chú thích rồi mà bạn:
Mã: 
    For i = LBound(arr, 1) + 1 To UBound(arr, 1)
        MaVanDon = arr(i, 1)        'Ma Van don file nguon
        ThoiGianKyNhan = arr(i, 12) 'Thoi gian ky nhan
        sTinhThanh = arr(i, 19)     'Tinh Thanh
        dic.Item(MaVanDon) = Array(ThoiGianKyNhan, sTinhThanh)
    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 2)
    For i = LBound(arr, 1) + 1 To UBound(arr, 1)
        MaVanDon = arr(i, 2) 'Ma Van Don file ket qua
        If dic.Exists(MaVanDon) Then
            result(i, 1) = dic.Item(MaVanDon)(0)
            result(i, 2) = dic.Item(MaVanDon)(1)
        End If
    Next i
Nhấp chuột vào đây để mở rộng...
Chết rồi, mình thử lại thì code bạn đúng nhưng vấn đề là do file mình muốn ghép lần này bị trùng MVĐ cho nên ra số sai -,-

Trường hợp bị trùng MVĐ, nếu yêu cầu mới như thế này bạn xem thực hiện được không nha (do kế toán không cấn trừ một lần mà thể hiện 1 MVĐ có tiền COD riêng và tiền cước phí riêng)

+Ví dụ, MVĐ: 842203689399 (chỗ tô đen đậm và tô đỏ - bị trùng MVĐ), mình muốn lấy cột số 6 (Tiền COD: 2165000) và cột số 13 (Tiền thực nhận: -128000) --> đưa 2 giá trị nào vào file đích cùng MVĐ.
Mình thấy nó có đặc điểm là lúc cột 13 có giá trị, thì cột 6 luôn = 0, mình có gửi đính kèm file này trong bài.

*Cột số 13 cũng không quan trọng lắm, nếu phức tạp quá thì bạn có thể cho mình xin code trùng MVĐ thì chỉ copy cột số 6 tiền COD >0 (hiện tại toàn copy số 0)
1687588233205.png
 

File đính kèm

  • ketoan.xlsx
    13.2 KB · Đọc: 2
Upvote 0
acrox84 đã viết:
Chết rồi, mình thử lại thì code bạn đúng nhưng vấn đề là do file mình muốn ghép lần này bị trùng MVĐ cho nên ra số sai -,-

Trường hợp bị trùng MVĐ, nếu yêu cầu mới như thế này bạn xem thực hiện được không nha (do kế toán không cấn trừ một lần mà thể hiện 1 MVĐ có tiền COD riêng và tiền cước phí riêng)

+Ví dụ, MVĐ: 842203689399 (chỗ tô đen đậm và tô đỏ - bị trùng MVĐ), mình muốn lấy cột số 6 (Tiền COD: 2165000) và cột số 13 (Tiền thực nhận: -128000) --> đưa 2 giá trị nào vào file đích cùng MVĐ.
Mình thấy nó có đặc điểm là lúc cột 13 có giá trị, thì cột 6 luôn = 0, mình có gửi đính kèm file này trong bài.

*Cột số 13 cũng không quan trọng lắm, nếu phức tạp quá thì bạn có thể cho mình xin code trùng MVĐ thì chỉ copy cột số 6 tiền COD >0 (hiện tại toàn copy số 0)
View attachment 291892
Nhấp chuột vào đây để mở rộng...
Copy từ đâu sang đâu bạn nhỉ, mình thấy form này khác các form trước phải không?
 
Upvote 0
Hoàng Nhật Phương đã viết:
Copy từ đâu sang đâu bạn nhỉ, mình thấy form này khác các form trước phải không?
Nhấp chuột vào đây để mở rộng...
từ file ketoan.xlsx sang file dulieu (form file dulieu cũ, mình có thay file ketoan sau khi phát hiện trả tiền COD có sai sót nên muốn ứng dụng tool ghép của bạn để đối chiếu 2 cột gần nhau)
 
Upvote 0
Hoàng Tuấn 868 đã viết:
Nếu thay file thì nên nhờ viết hoặc nhờ chỉnh code lại chứ ai lại bảo bị sai như bài #34 nhỉ. Nghe vậy người viết code chắc cũng có đôi chút chạnh lòng.
Nhấp chuột vào đây để mở rộng...
bạn nói đúng cái này là lỗi do mình, nhu cầu ban đầu của mình thì bạn Phương hoàn thiện rất tốt rồi, mình có báo ở bài #33

Còn #34 là mình hỏi để sử dụng lại tool này vào việc khác. Do mấy ngày trước, mình phát hiện file mình export thanh toán tiền khác với file kế toán.
Đó là trường hợp 1 khách lập đơn để tiền thu hộ COD 900k, hôm sau lại báo điều chỉnh lại về 0đ --> mình trả dư khách mất 900k.
Mình đang nghĩ cách đối chiếu số liệu giữa 2 file này thì nhớ code bạn Phương cho có khả năng tùy biến chép cột nên mình định chép 2 cột COD gần nhau để so sánh.

Do số lượng MVĐ ở 1 file rất nhiều và mình không nghĩ 1 MVĐ mà kế toán nó tách ra 2 lần, một lần trả tiền COD, một lần trả tiền cước, phiền phức như vậy. Nên sau khi phát hiện, mình cũng sợ hiểu lầm nên #36 khẳng định lại code bạn đúng.
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

H
Nhờ gở rối công thức Averageif trong sheet summary
Trả lời
3
Đọc
19
ptm0412
ptm0412
trungvinh252
Xuất ngày tháng gần nhất được đánh dấu. Xin giúp đỡ ạ.
Trả lời
1
Đọc
78
HieuCD
H
NguyenthiH
Công thức tạo số phiếu xuất.
Trả lời
11
Đọc
222
NguyenthiH
NguyenthiH
C
Xin công thức xếp loại có điều kiện.
Trả lời
4
Đọc
170
Hoàng Tuấn 868
H
noisy
Nhờ hỗ trợ tạo thống kê
Trả lời
5
Đọc
160
tranhungdao12a3
T
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom