Сравнить несколько столбцов и результат скопировать в другой файл. Не могу найти ошибку. - VB

Узнай цену своей работы

Формулировка задачи:

День добрый
Не получилось переделать макрос для следующего задания:
Нужно таблицу состоящей из 4-х столбцов из файла №1 - первый наименование, 3 других числовые, сравнить с другим файлом №2, и в случае совпадения наименования и 2 других столбцов скопировать в файл №2 содержимое 3-го столбца с цифрами.
Никто не может подсказать, в чем тут ошибка?
Option Explicit
Sub Test1()
Const DataRange = "A:E"
Dim Arr1(), Arr2(), Arr3(), Arr4(), r&, c&, rs&, ds&, cs&, rs1&, ds1&, cs1&, i&, r1&, c1&
Arr1() = Intersect(ActiveSheet.UsedRange, Range(DataRange)).Value
rs = UBound(Arr1, 3)
cs = UBound(Arr1, 4)
ds = UBound(Arr1, 5)
ReDim Arr2(1 To rs, 1 To 1)
Windows("ëèñò2").Activate
rs1 = UBound(Arr3, 3)
cs1 = UBound(Arr3, 4)
ds1 = UBound(Arr1, 5)
ReDim Arr4(1 To rs, 1 To 1)
Windows("ëèñò1").Activate
For c = 1 To cs Step 3
For r = 1 To rs
If Arr1(r, c + 2) = Cells(r1, c1 + 2) Then
If Arr1(r, c + 3) = Cells(r1, c1 + 3) Then
If Arr1(r, c + 4) = Cells(r1, c1 + 4) Then
i = i + 1
Arr2(i, 1) = Arr1(r, c + 2)
End If
End If
End If
Next
Next
ReDim Arr1(0)
If i > 0 Then
If i > Rows.Count Then MsgBox "Íàéäåíî: " & i, 16, "!": Exit Sub
On Error Resume Next
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets("Result").Delete
With Sheets.Add
.Name = "Result"
Range("F1").Resize(i).Value = Arr2()
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End If
End Sub

Решение задачи: «Сравнить несколько столбцов и результат скопировать в другой файл. Не могу найти ошибку.»

textual
Листинг программы
rs = UBound(Arr1, 3)
cs = UBound(Arr1, 4)
ds = UBound(Arr1, 5)

ИИ поможет Вам:


  • решить любую задачу по программированию
  • объяснить код
  • расставить комментарии в коде
  • и т.д
Попробуйте бесплатно

Оцени полезность:

7   голосов , оценка 4.143 из 5
Похожие ответы