Здравствуйте, помогите пожалуйста в написании макроса
Есть фаил на нем 2 листа Нужно с листа 2 взять В2 (первую ячейку из диапазона В2:В1000) и найти на листе 1 в диапазоне В2:В1500, мы нашли и допустим это В6 на 1 листе, нужно взять и сравнить С2 со 2 листа с ячейкой С6 на 1 листе, если они равны, сравнить D2 со 2 листа с ячейкой D6 с 1 листа: - если и они равны то тогда на первом листе в ячейке E6 поставить значение со второго листа из Е2 - если и они не равны то тогда на первом листе в самом низу таблицы заполнить ячейки В1001, С1001, D1001, E1001 значениями со второго листа В2, С2, D2, E2
таким образом нужно проверить весь диапазон В2:В1000 со второго листа
Заранее благодарю.
Здравствуйте, помогите пожалуйста в написании макроса
Есть фаил на нем 2 листа Нужно с листа 2 взять В2 (первую ячейку из диапазона В2:В1000) и найти на листе 1 в диапазоне В2:В1500, мы нашли и допустим это В6 на 1 листе, нужно взять и сравнить С2 со 2 листа с ячейкой С6 на 1 листе, если они равны, сравнить D2 со 2 листа с ячейкой D6 с 1 листа: - если и они равны то тогда на первом листе в ячейке E6 поставить значение со второго листа из Е2 - если и они не равны то тогда на первом листе в самом низу таблицы заполнить ячейки В1001, С1001, D1001, E1001 значениями со второго листа В2, С2, D2, E2
таким образом нужно проверить весь диапазон В2:В1000 со второго листа
Sub test() Dim sh1 As Worksheet, sh2 As Worksheet, x As Range, dic As Object Dim i&, lr&, iKey$ Set sh1 = ThisWorkbook.Sheets(1) Set sh2 = ThisWorkbook.Sheets(2) Set dic = CreateObject("scripting.dictionary") With sh1 For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row iKey = Trim(.Cells(i, "b") & "@" & .Cells(i, "c") & "@" & .Cells(i, "d")) dic(iKey) = i Next i End With With sh2 For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row iKey = Trim(.Cells(i, "b") & "@" & .Cells(i, "c") & "@" & .Cells(i, "d")) If dic.exists(iKey) Then sh1.Cells(dic(iKey), "e") = .Cells(i, "e") Else lr = sh1.Cells(Rows.Count, 2).End(xlUp).Row + 1 sh1.Cells(lr, "b") = .Cells(i, "b") sh1.Cells(lr, "c") = .Cells(i, "c") sh1.Cells(lr, "d") = .Cells(i, "d") sh1.Cells(lr, "e") = .Cells(i, "e") End If Next i End With End Sub
[/vba]
boy22, здравствуйте. Так подойдет? [vba]
Код
Sub test() Dim sh1 As Worksheet, sh2 As Worksheet, x As Range, dic As Object Dim i&, lr&, iKey$ Set sh1 = ThisWorkbook.Sheets(1) Set sh2 = ThisWorkbook.Sheets(2) Set dic = CreateObject("scripting.dictionary") With sh1 For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row iKey = Trim(.Cells(i, "b") & "@" & .Cells(i, "c") & "@" & .Cells(i, "d")) dic(iKey) = i Next i End With With sh2 For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row iKey = Trim(.Cells(i, "b") & "@" & .Cells(i, "c") & "@" & .Cells(i, "d")) If dic.exists(iKey) Then sh1.Cells(dic(iKey), "e") = .Cells(i, "e") Else lr = sh1.Cells(Rows.Count, 2).End(xlUp).Row + 1 sh1.Cells(lr, "b") = .Cells(i, "b") sh1.Cells(lr, "c") = .Cells(i, "c") sh1.Cells(lr, "d") = .Cells(i, "d") sh1.Cells(lr, "e") = .Cells(i, "e") End If Next i End With End Sub