На другом форуме мне не смогли подсказать. Может быть у Вас получится что то узнать.
Есть файл на листе 1 которого, представленны данные ввиде таблицы (дата, время, и прочее) в некоторых из строк , некоторые ячейки выделены жирным. И есть лист 2 на котором есть список дат, и времени, и третий столбец который требует заполнения.
макрос должен сравнивать первые два столбца (только в связке) на листе 1 с данными листа два, находить полные совпадения после чего смотреть есть ли на листе 1 в совпадающей строке ячейки выделенные жирным, и если есть то на лице 2 ставить 1
Файл пример также прикрепил.
Спасибо всем кто прочтет, или тем более откликнется.
пытался как то приспособить данный макрос... но ничего не вышло(
[vba]
Код
Sub Find_Matches() Dim CompareRange As Variant, x As Variant, y As Variant
Set CompareRange = Worksheets("Лист1").Range("A1:B100") For Each x In CompareRange For Each y In Selection If x = y And y.Font.Bold Then x.Offset(0, 3) = "Fix" Next y Next x End Sub
На другом форуме мне не смогли подсказать. Может быть у Вас получится что то узнать.
Есть файл на листе 1 которого, представленны данные ввиде таблицы (дата, время, и прочее) в некоторых из строк , некоторые ячейки выделены жирным. И есть лист 2 на котором есть список дат, и времени, и третий столбец который требует заполнения.
макрос должен сравнивать первые два столбца (только в связке) на листе 1 с данными листа два, находить полные совпадения после чего смотреть есть ли на листе 1 в совпадающей строке ячейки выделенные жирным, и если есть то на лице 2 ставить 1
Файл пример также прикрепил.
Спасибо всем кто прочтет, или тем более откликнется.
пытался как то приспособить данный макрос... но ничего не вышло(
[vba]
Код
Sub Find_Matches() Dim CompareRange As Variant, x As Variant, y As Variant
Set CompareRange = Worksheets("Лист1").Range("A1:B100") For Each x In CompareRange For Each y In Selection If x = y And y.Font.Bold Then x.Offset(0, 3) = "Fix" Next y Next x End Sub
KOLLIAK, как понял, так и сделал. Попробуйте так: [vba]
Код
Sub Opr_FontSt() Dim i&, k& Dim o As Object, key As String Dim r As Range Set o = CreateObject("Scripting.Dictionary") i_n& = Worksheets(2).Cells(Rows.count, 1).End(xlUp).Row For i = 1 To i_n key = Worksheets(2).Cells(i, 1).Text & Worksheets(2).Cells(i, 2).Text If Not o.exists(key) Then k = k + 1 o.Add key, k End If Next i i_n& = Worksheets(1).Cells(Rows.count, 1).End(xlUp).Row For i = 1 To i_n key = Worksheets(1).Cells(i, 1).Text & Worksheets(1).Cells(i, 2).Text If o.exists(key) Then For Each r In Worksheets(1).Cells(i, 3).Resize(, 7) If r.Font.Bold Then Worksheets(2).Cells(o(key), 3) = 1 Exit For End If Next r End If Next i End Sub
[/vba]
KOLLIAK, как понял, так и сделал. Попробуйте так: [vba]
Код
Sub Opr_FontSt() Dim i&, k& Dim o As Object, key As String Dim r As Range Set o = CreateObject("Scripting.Dictionary") i_n& = Worksheets(2).Cells(Rows.count, 1).End(xlUp).Row For i = 1 To i_n key = Worksheets(2).Cells(i, 1).Text & Worksheets(2).Cells(i, 2).Text If Not o.exists(key) Then k = k + 1 o.Add key, k End If Next i i_n& = Worksheets(1).Cells(Rows.count, 1).End(xlUp).Row For i = 1 To i_n key = Worksheets(1).Cells(i, 1).Text & Worksheets(1).Cells(i, 2).Text If o.exists(key) Then For Each r In Worksheets(1).Cells(i, 3).Resize(, 7) If r.Font.Bold Then Worksheets(2).Cells(o(key), 3) = 1 Exit For End If Next r End If Next i End Sub
Sub test() Set sh1 = ThisWorkbook.Sheets(1) Set sh2 = ThisWorkbook.Sheets(2) With sh1 lr = .Cells(Rows.Count, 1).End(xlUp).Row lc = .Cells(1, Columns.Count).End(xlToLeft).Column Set dic = CreateObject("scripting.dictionary") For i = 2 To lr For j = 3 To lc If .Cells(i, j) = "ок" And .Cells(i, j).Font.Bold = True Then dic.Add Trim(.Cells(i, 1) & "|" & .Cells(i, 2)), i End If Next j Next i End With With sh2 lr = .Cells(Rows.Count, 1).End(xlUp).Row .[c1].Resize(lr).ClearContents For i = 2 To lr If dic.Exists(Trim(.Cells(i, 1) & "|" & .Cells(i, 2))) Then .Cells(i, 3) = 1 Next i End With End Sub
[/vba]
И у меня тоже со словариком ) [vba]
Код
Sub test() Set sh1 = ThisWorkbook.Sheets(1) Set sh2 = ThisWorkbook.Sheets(2) With sh1 lr = .Cells(Rows.Count, 1).End(xlUp).Row lc = .Cells(1, Columns.Count).End(xlToLeft).Column Set dic = CreateObject("scripting.dictionary") For i = 2 To lr For j = 3 To lc If .Cells(i, j) = "ок" And .Cells(i, j).Font.Bold = True Then dic.Add Trim(.Cells(i, 1) & "|" & .Cells(i, 2)), i End If Next j Next i End With With sh2 lr = .Cells(Rows.Count, 1).End(xlUp).Row .[c1].Resize(lr).ClearContents For i = 2 To lr If dic.Exists(Trim(.Cells(i, 1) & "|" & .Cells(i, 2))) Then .Cells(i, 3) = 1 Next i End With End Sub
достаточно вот здесь поменять 7 на необходимое число?
да, Вы верно поняли, метод Resize(,) так и работает. Изменяет диапазон на Resize(количество строк, количество столбцов). Если пишем Resize(n) изменяем только по строкам, если Resize(, n) - изменяем только по столбцам.
достаточно вот здесь поменять 7 на необходимое число?
да, Вы верно поняли, метод Resize(,) так и работает. Изменяет диапазон на Resize(количество строк, количество столбцов). Если пишем Resize(n) изменяем только по строкам, если Resize(, n) - изменяем только по столбцам.Roman777