在两个工作簿之间匹配数据并粘贴数据基于

Question

我正在处理的情况是一个表格，其中第一列是帐号，第五列是金额，第七列是“F”或“P”。帐号与位于第一列中另一个工作簿上的帐号相匹配。如果在表格的第七列（在源工作簿中，有一个“F”，则该值应该被复制、匹配并粘贴到目标工作簿第四列的同一行。如果有一个“ P,' 值应匹配并粘贴到目标工作簿第五列的同一行。代码有效，但无法区分 F 或 P。它将所有值都粘贴到两列中。

Private Sub CommandButton2_Click()
Dim Dic As Object, key As Variant, oCell As Range, i&
Dim w1 As Worksheet, w2 As Worksheet
Dim cell As Range
Dim SrchRng As Range

Set Dic = CreateObject("Scripting.Dictionary")
Set w1 = Workbooks("HF Pricing Template1").Sheets("Tables")
Set w2 = Workbooks("Book1").Sheets("Sheet1")
Set SrchRng = Range("Table3[Price_Type]")

For Each cell In SrchRng
If cell.Value = "P" Then

i = w1.Cells.SpecialCells(xlCellTypeLastCell).Row

    For Each oCell In w1.Range("M5:M" & i)
        If Not Dic.exists(oCell.Value) Then
            Dic.Add oCell.Value, oCell.Offset(, 5).Value
        End If
    Next


 i = w2.Cells.SpecialCells(xlCellTypeLastCell).Row

    For Each oCell In w2.Range("A2:A" & i)
        For Each key In Dic
            If oCell.Value = key Then
                oCell.Offset(, 3).Value = Dic(key)
            End If
        Next
    Next
End If

Next cell
For Each cell In SrchRng
If cell.Value = "P" Then

   i = w1.Cells.SpecialCells(xlCellTypeLastCell).Row

    For Each oCell In w1.Range("M5:M" & i)
        If Not Dic.exists(oCell.Value) Then
            Dic.Add oCell.Value, oCell.Offset(, 5).Value
        End If
    Next


    i = w2.Cells.SpecialCells(xlCellTypeLastCell).Row

    For Each oCell In w2.Range("A2:A" & i)
        For Each key In Dic
            If oCell.Value = key Then
                oCell.Offset(, 4).Value = Dic(key)
            End If
        Next
    Next
 End If

 Next cell

End Sub

Answer 1

这次完全重写怎么样。

阅读 cmets 以获得解释

'compare text (ignore case)
option compare text 

dim source_wb as workbook
dim dest_wb as workbook

dim source_ws as worksheet
dim dest_ws as worksheet

'set workbooks/sheets
set source_wb = workbooks("HF Pricing Template1")
set source_ws = source_wb.worksheets("Table")

set dest_wb = workbooks("Book1")
set dest_ws = dest_wb.worksheets("Sheet1")

dim source_lr as integer
dim dest_lr as integer

'get last row of data in each sheet for column 1 (the account numbers)
'checks for account number list in column "a" change where applicable
source_lr = source_ws.cells(rows.count, "M").end(xlup).row
dest_lr = dest_ws.cells(rows.count, "A").end(xlup).row


'this starts checking for account numbers at row 2 change where applicable
for source_row = 2 to source_lr
    ''this start checking for account numbers at row 2 change where applicable
    for dest_row = 2 to dest_lr
        'check if account numbers match
        ' change column as applicable 
        if source_ws.cells(source_row, "M") = dest_ws.cells(dest_row, "A") then
            'if column 7  in source contains p then copy to column 4 in dest ws
            'change column where applicable
            if source_ws.cells(source_row, "S") = "p" then
                dest_ws.cells(dest_row,"D") = source_ws.cells(source_row, "R")
                exit for
  
            'if column 7  in source contains f then copy to column 5 in dest ws
            ' change column where applicable
            elseif source_ws.cells(source_row, "S") = "f" then
                dest_ws.cells(dest_row, "E") = source_ws.cells(source_row, "R")
                exit for
            end if
        end if
    next dest_row
next source_row

请注意 - 我不在 Windows 机器上，现在无法测试它，但它应该可以按预期工作。

Answer 2

Dim source_wb As Workbook
Dim dest_wb As Workbook

Dim source_ws As Worksheet
Dim dest_ws As Worksheet

'set workbooks/sheets
Set source_wb = Workbooks("HF Pricing Template1")
Set source_ws = source_wb.Worksheets("Tables")

Set dest_wb = Workbooks("Book1")
Set dest_ws = dest_wb.Worksheets("Sheet1")

Dim source_lr As Integer
Dim dest_lr As Integer

'get last row of data in each sheet for column 1 (the account numbers)
'checks for account number list in column "a" change where applicable
source_lr = source_ws.Cells(Rows.Count, "M").End(xlUp).Row
dest_lr = dest_ws.Cells(Rows.Count, "A").End(xlUp).Row


'this starts checking for account numbers at row 2 change where applicable
For source_row = 5 To source_lr
''this start checking for account numbers at row 2 change where applicable
For dest_row = 2 To dest_lr
    'check if account numbers match
    ' change column as applicable
    If source_ws.Cells(source_row, "M") = dest_ws.Cells(dest_row, "A") Then
        'if column 7  in source contains p then copy to column 4 in dest ws
        'change column where applicable
        If source_ws.Cells(source_row, "S") = "P" Then
            dest_ws.Cells(dest_row, "D") = source_ws.Cells(source_row, "M")
            Exit For
        'if column 7  in source contains f then copy to column 5 in dest ws
        ' change column where applicable
        ElseIf source_ws.Cells(source_row, "S") = "F" Then
            dest_ws.Cells(dest_row, "E") = source_ws.Cells(source_row, "M")
            Exit For

        End If
     End If
   Next
 Next