Sub tt()
Dim a(), b(), i&, ii&, t
With CreateObject("scripting.dictionary")
a = Sheets(2).[a2].CurrentRegion.Value ' на листе 2
For i = 2 To UBound(a)
t = a(i, 1) ' t = Trim(a(i, 2))
If Not .Exists(t) Then
.Item(t) = i
Else
' MsgBox "Повтор номера " & vbNewLine & t, vbCritical
Sheets(2).Cells(i, 1).Interior.Color = 65535
End If
Next
b = Sheets(1).[c2].CurrentRegion.Value ' на листе 1
For i = 2 To UBound(b) ' проходим по листу 1
If .Exists(b(i, 1)) Then ' если ячейка не пустая
If .Item(b(i, 1)) Then ' если номер строки >0
ii = .Item(b(i, 1))
.Item(b(i, 1)) = 0 ' номер уже использовался, блокируем дубликаты
b(i, 3) = a(ii, 2)
b(i, 5) = a(ii, 3) ' координаты в массиве, строка и колонка
Sheets(1).Cells(i, 5).Value = b(i, 3)
Sheets(1).Cells(i, 7).Value = b(i, 5)
Else
Sheets(1).Cells(i, 3).Interior.Color = 65535
End If
End If
Next
' Sheets(1).[c1].CurrentRegion.Value = b
End With
' For Each c In Intersect(Sheets(1).UsedRange, Sheets(1).Columns(3)).Cells
' t = c.Value ' t = Trim(c.Value)
' If .Exists(t) Then
' x = .Item(t): '.Item(t) = 1
' c.Offset(, 4) = a(x, 2)
' c.Offset(, 5) = a(x, 3)
' Cells(c.Offset(, 4)) = Cells(a(x, 2))
' End If
' Next
End Sub
Sub ttt()
Dim a(), b(), t&, i&
With CreateObject("Scripting.Dictionary"): .CompareMode = 1
a = Sheets(2).[a2].CurrentRegion.Value
For i = 2 To UBound(a): .Item(a(i, 1)) = i: Next
b = Sheets(1).[c2].CurrentRegion.Value ' на листе 1
For i = 2 To UBound(b)
t = .Item(b(i, 1))
b(i, 3) = a(t, 2)
b(i, 5) = a(t, 3) ' координаты в массиве, строка и колонка
Next
'тут перенос кода на новую строку!
Sheets(1).[c1].CurrentRegion.Value = b
End With
End Sub
Sub QWER()
Dim R, M
Dim o2: Set o2 = CreateObject("scripting.Dictionary")
Dim o3: Set o3 = CreateObject("scripting.Dictionary")
With Лист2
M = .Range("A1").Resize(.Cells(.Rows.Count, 1).End(xlUp).Row)
For R = 1 To UBound(M): o2(M(R, 1)) = 4: Next '4 индекс цвета заливки
End With
With Лист3
M = .Range("A1").Resize(.Cells(.Rows.Count, 1).End(xlUp).Row)
For R = 1 To UBound(M): o3(M(R, 1)) = 6: Next ' 6 индекс цвета заливки
End With
With Лист1
M = .Range("A1").Resize(.Cells(.Rows.Count, 1).End(xlUp).Row)
For R = 1 To UBound(M)
If o2.Exists(M(R, 1)) Then Лист1.Cells(R, 2).Interior.ColorIndex = o2(M(R, 1))
If o3.Exists(M(R, 1)) Then Лист1.Cells(R, 3).Interior.ColorIndex = o3(M(R, 1))
Next
End With
End Sub
|