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 · 7/4/23

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

acrox84 · 17/5/23

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.

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.

Hoàng Nhật Phương · 17/5/23

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.

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

acrox84 · 17/5/23

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

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 ạ

acrox84 · 17/5/23

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:

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!

Hoàng Nhật Phương · 17/5/23

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

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 ạ

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 đó.

acrox84 · 17/5/23

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 đó.

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.

Hoàng Nhật Phương · 17/5/23

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

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.

acrox84 · 17/5/23

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.

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!

acrox84 · 23/6/23

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

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!

Hoàng Nhật Phương · 23/6/23

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!

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ỉ?

acrox84 · 23/6/23

Hoàng Nhật Phương đã viết:
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ỉ?

mình gửi đính kèm lại file Ghep NgayGiao và 2 file dữ liệu.

Hoàng Nhật Phương · 23/6/23

acrox84 đã viết:
mình gửi đính kèm lại file Ghep NgayGiao và 2 file dữ liệu.

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

acrox84 · 23/6/23

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

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

acrox84 · 24/6/23

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

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:

Hoàng Nhật Phương · 24/6/23

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

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

acrox84 · 24/6/23

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

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)

Hoàng Nhật Phương · 25/6/23

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

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?

acrox84 · 25/6/23

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?

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)

Hoàng Tuấn 868 · 25/6/23

acrox84 đã viết:
mình có thay file ketoan

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.

acrox84 · 25/6/23

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.

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.

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

Thành viên hoạt động

File đính kèm

Thành viên hoạt động

Thành viên gắn bó

File đính kèm

Thành viên hoạt động

Thành viên hoạt động

Thành viên gắn bó

File đính kèm

Thành viên hoạt động

Thành viên gắn bó

Thành viên hoạt động

Thành viên hoạt động

Thành viên gắn bó

Thành viên hoạt động

File đính kèm

Thành viên gắn bó

Thành viên hoạt động

Thành viên hoạt động

Thành viên gắn bó

Thành viên hoạt động

File đính kèm

Thành viên gắn bó

Thành viên hoạt động

Đăng ký hôm qua

Thành viên hoạt động

Đếm ngược thời gian