Добрый день.
Как поменять код чтобы в 22 счет на листе 1 перенеслась сумма и компания (но логика остальная сохранилась бы)?
Как поменять код чтобы в 22 счет на листе 1 перенеслась сумма и компания (но логика остальная сохранилась бы)?
| Код |
|---|
Sub СопоставитьСчета()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim lastRow1 As Long
Dim lastRow2 As Long
Dim i As Long
Dim j As Long
Dim currentRow As Long
Dim companyFound As Boolean
' Установим ссылки на листы по индексам
Set ws1 = ThisWorkbook.Sheets(1) ' Первый лист в книге
Set ws2 = ThisWorkbook.Sheets(2) ' Второй лист в книге
' Найдем последнюю строку в каждом листе
lastRow1 = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
lastRow2 = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
' Проходим по всем счетам на Листе1
For i = 2 To lastRow1 + 1000 ' Начинаем с 2, чтобы пропустить заголовок на Листе1, + 1000 добавлено эксперементальным путем
If ws1.Cells(i, 1).Value <> "" Then ' Проверяем, что счет не пустой
' Ищем совпадения по счету и компании на Листе2, + 1000 добавлено эксперементальным путем
For j = 2 To lastRow2 + 1000
If ws1.Cells(i, 1).Value = ws2.Cells(j, 1).Value Then ' Совпадение по счету
companyFound = False
If ws1.Cells(i, 2).Value = ws2.Cells(j, 2).Value Then ' Совпадение по компании
companyFound = True
' Переносим сумму из Листа2 в Лист1
ws1.Cells(i, 3).Value = ws2.Cells(j, 3).Value
End If
End If
Next j
' Если компания не найдена на Листе2 для данного счета, добавляем новые строки с компаниями из Листа2 под последней найденной компанией для этого счета на Листе1
If Not companyFound Then
For j = 2 To lastRow2
If ws1.Cells(i, 1).Value = ws2.Cells(j, 1).Value And _
Application.WorksheetFunction.CountIf(ws1.Range("B:B"), ws2.Cells(j, 2).Value) = 0 Then
i = i + 1 ' Переходим к следующей строке для вставки новой компании
' Вставляем новую строку и переносим данные из Листа2 в Лист1
ws1.Rows(i).Insert Shift:=xlDown
ws1.Cells(i, 1).Value = ws2.Cells(j, 1).Value
ws1.Cells(i, 2).Value = ws2.Cells(j, 2).Value
ws1.Cells(i, 3).Value = ws2.Cells(j, 3).Value
End If
Next j
End If
End If
Next i
MsgBox "Сопоставление завершено!"
End Sub |
Изменено: - 11.05.2025 12:00:05
