Уважаемые форумчане! Нужна помощь с доработкой макроса! В предыдущей теме благодаря помощи форумчан была решена задача переноса данных по двум критериям, но в процессе использования программы возникло две проблемы:
1. При переносе данных, книга куда переносятся данные оцифровывается (формулы преобразуются в числа),
2. Выяснилось, что может быть вариант при котором совпадают несколько раз строки (по двум столбцам), как можно перенести -эти данные ещё дальше (правее).
Код которым пользуюсь в данный момент:
1. При переносе данных, книга куда переносятся данные оцифровывается (формулы преобразуются в числа),
2. Выяснилось, что может быть вариант при котором совпадают несколько раз строки (по двум столбцам), как можно перенести -эти данные ещё дальше (правее).
Код которым пользуюсь в данный момент:
| Код |
|---|
Sub Синхронизация()
Dim sht As Worksheet, sht1 As Worksheet
Dim arr(), arr1(), i&, j&, x&, y&
Set sht = Workbooks("Книга1.xlsx").Sheets("Лист1")
Set sht1 = ThisWorkbook.ActiveSheet
With sht
i = .Cells(.Rows.Count, "a").End(xlUp).Row
j = .Cells(4, .Columns.Count).End(xlToLeft).Column
arr = .Range(.Cells(5, "a"), .Cells(i, j))
End With
With sht1
i = .Cells(.Rows.Count, "a").End(xlUp).Row
arr1 = .Range(.Cells(15, "a"), .Cells(i, 70))
For i = LBound(arr1) To UBound(arr1)
For j = LBound(arr) To UBound(arr)
If arr1(i, 2) = arr(j, 2) And arr1(i, 3) = arr(j, 3) Then
y = 3
For x = UBound(arr1, 2) - 39 To UBound(arr1, 2)
arr1(i, x) = arr(j, y)
y = y + 1
Next x
End If
Next j
Next i
.Range("a15").Resize(UBound(arr1), UBound(arr1, 2)) = arr1
End With
End Sub |
