Есть 2 массива на разных листах, данные представляют собой буквенно-числовые коды: 1 лист - данные добавляются/изменяются 2 лист - данные не изменяются, представлены все возможные комбинации кодов
Нужно, чтобы ячейки на 2 листе подсвечивались цветом (например, жёлтый), если они совпадают с данными на 1 листе.
Написал процедуру, но правильно она не работает:
Код
Sub Fleet()
Dim w1 As Worksheet, w2 As Worksheet
Dim o1R As Object, o1C As Object
Dim o2R As Object, o2C As Object
Dim lngMaxR As Long, intMaxC As Integer
Dim lngR As Long, intC As Integer
Dim var1 As Variant, var2 As Variant
Set w1 = Worksheets(1)
Set w2 = Worksheets(2)
Set o1R = w1.UsedRange.Rows
Set o1C = w1.UsedRange.Columns
Set o2R = w2.UsedRange.Rows
Set o2C = w2.UsedRange.Columns
Application.ScreenUpdating = False
If o1R.Count > o2R.Count Then
lngMaxR = o1R.Count
Else
lngMaxR = o2R.Count
End If
If o1C.Count > o2C.Count Then
intMaxC = o1C.Count
Else
intMaxC = o2C.Count
End If
For intC = 1 To intMaxC
For lngR = 1 To lngMaxR
var1 = w1.Cells(lngR, intC)
var2 = w2.Cells(lngR, intC)
If var1 = var2 Then
w2.Cells(lngR, intC).Interior.Color = vbYellow
End If
Next lngR
Next intC
Application.ScreenUpdating = True
Set w1 = Nothing
Set w2 = Nothing
Set o1R = Nothing
Set o1C = Nothing
Set o2R = Nothing
Set o2C = Nothing
End Sub
Соответственно, 1 лист - данные добавляются по столбцам, слева-направо 2 лист - если значение любой ячейки совпадает со значением ячейки 1 листа - она должна подкрашиваться
Sub povt()
Dim i As Range, lr As Long, cell As Range, sh As Worksheet, sh2 As Worksheet, cell2 As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set sh = Worksheets("Sheet1"): Set sh2 = Worksheets("Sheet2")
Set rngsh = sh.Range(sh.Range("A1"), sh.Range("A1").SpecialCells(xlLastCell))
Set rngsh2 = sh2.Range(sh2.Range("B1"), sh2.Range("B1").SpecialCells(xlLastCell))
For Each cell In rngsh2
If Not cell Is Nothing Then
If Application.WorksheetFunction.CountIf(rngsh, cell) > 0 Then
If cell2 Is Nothing Then
Set cell2 = cell
Else
Set cell2 = Union(cell2, cell)
End If
End If
End If
Next cell
If Not cell2 Is Nothing Then cell2.Font.Color = 75962
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub Fleet()
Application.ScreenUpdating = False
With CreateObject("Scripting.Dictionary")
For Each c In Worksheets(1).UsedRange.Cells
.Item(c.Value) = 0&
Next
For Each c In Worksheets(2).UsedRange.Cells
If .exists(c.Value) Then c.Interior.Color = vbYellow
Next
End With
Application.ScreenUpdating = True
End Sub
Не для Маков. Нужно ли сперва снимать заливку, и нужно ли учитывать пустые - мне неведомо.
Sub Fleet()
Application.ScreenUpdating = False
With CreateObject("Scripting.Dictionary")
For Each c In Worksheets(1).UsedRange.SpecialCells(xlCellTypeConstants, 2).Cells 'UsedRange.Cells
.Item(c.Value) = 0&
Next
For Each c In Worksheets(2).UsedRange.SpecialCells(xlCellTypeConstants, 2).Cells 'UsedRange.Cells
If .exists(c.Value) Then c.Interior.Color = vbYellow
Next
End With
Application.ScreenUpdating = True
End Sub
Hugo Не для Маков.Нужно ли сперва снимать заливку, и нужно ли учитывать пустые - мне неведомо.
а мне не для маков и нужно как раз. Пустые ячейки учитывать не нужно, по Вашему коду она и пустые заливает тоже. Заливку сначала можно и не снимать, там ничего не заливается.
Mershik написал: Код ? 123456789101112131415Sub povt()Dim cell As Range, sh As Worksheet, sh2 As WorksheetApplication.ScreenUpdating = FalseApplication.DisplayAlerts = FalseSet sh = Worksheets("Sheet1"): Set sh2 = Worksheets("Sheet2")Set rngsh = sh.Range(sh.Range("A1"), sh.Range("A1").SpecialCells(xlLastCell))Set rngsh2 = sh2.Range(sh2.Range("B1"), sh2.Range("B1").SpecialCells(xlLastCell))For Each cell In rngsh2 If Not cell Is Nothing Then If Application.WorksheetFunction.CountIf(rngsh, cell) > 0 Then cell.Font.Color = 75962 End IfNext cellApplication.ScreenUpdating = TrueApplication.DisplayAlerts = TrueEnd Sub
Ваш вариант вроде рабочий, только мне как раз заливка ячейки нужна, не шрифта (цвет шрифта для меня тоже значение имеет). Но все в порядке, я поменял у себя 19ю строчку, работает
1. Посмотрите, как формлены сообщения других. Отформатируйте код в первом сообщении. Ищите кнопку <...> 2. О бестолковом цитировании написано в правилах форума. Пройдитесь по своим сообщениям и приведите их в прядок. Учитесь цитировать! Цитата - не бездумная копия.