Блог

Ситуация, с которой я имею дело, — это та, в которой есть таблица с номерами счетов в первом столбце, суммами в пятом столбце и ‘F’ или ‘P’ в седьмом столбце. Номера счетов совпадают с номерами счетов, расположенными в другой книге в первом столбце. Если в седьмом столбце таблицы (в исходной книге) есть «F», значение должно быть скопировано, сопоставлено и вставлено в ту же строку в четвертом столбце целевой книги. Если есть ‘P’, значение должно быть сопоставлено и вставлено в ту же строку в пятом столбце целевой книги. Код работает, но он не делает различий между F или P. Он вставляет все значения в оба столбца.

 Private Sub CommandButton2_Click()
Dim Dic As Object, key As Variant, oCell As Range, iamp;
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" amp; 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" amp; 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" amp; 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" amp; 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
  

 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
  

Как насчет этой полной перезаписи.

Прочитайте комментарии для объяснения

 '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 и не могу протестировать это прямо сейчас, но это должно работать так, как ожидалось.