所以我一直在研究一些识别两个范围之间唯一值的代码。然后,我希望复制并插入选定行,它位于相对位于范围2的位置。(请参阅下面的代码,其中显示****需要帮助)
我希望位于唯一值正下方的非唯一值可以在第一个范围内找到,也可以在其正上方插入一行。
另外,我打算在两个工作簿之间使用此代码。范围1和范围2将位于同一实例的不同工作簿中。
Option Explicit
Public WorkRng1 As Range
Public WorkRng2 As Range
Public WorkRng3 As Range
Public Rng1 As Range
Public Rng2 As Range
Public Rng3 As Range
Public blkRow As Range
Public Sub SetRanges()
Dim xTitleId As String
xTitleId = "Compare Ranges"
Set WorkRng1 = Application.InputBox("Please Select TASK ID Range in **INVOICE REVIEW FILE**", xTitleId, Type:=8)
Set WorkRng2 = Application.InputBox("Please Select TASK ID Range in **BUDGET GRID**", xTitleId, Type:=8)
Set WorkRng3 = Application.InputBox("Please Select **UNIT COST** Range in Budget Grid", xTitleId, Type:=8)
Call CompareRanges
'Error Handler
Whoa:
Select Case Err.Number
Case 1004
MsgBox "Check Your Column Letters!", vbInformation, "Oops!"
Case 424
Exit Sub
End Select
End Sub
Public Sub CompareRanges()
Dim blkRow As Range
'clears color format
WorkRng2.Interior.ColorIndex = xlNone
'finds duplicate values
For Each Rng1 In WorkRng1
For Each Rng2 In WorkRng2
If Rng1.Value = Rng2.Value Then
Rng2.Interior.Color = VBA.RGB(254, 255, 255)
Exit For
End If
Next
Next
'find unique values and highlights red
For Each Rng2 In WorkRng2
For Each Rng3 In WorkRng3
If Rng2.Value > 0 And Cells(Rng2.Row, Rng3.Column) <> 0 And Rng2.Interior.Color <> VBA.RGB(254, 255, 255) Then
Rng2.Interior.Color = VBA.RGB(255, 0, 0)
Exit For
End If
Next
Next
'promts to select blank row to copy
Set blkRow = Application.InputBox("Enter Row # of 'BLANK' with formulas", "BLANK ROW SELECTION", Type:=8)
blkRow.Copy
Application.CutCopyMode = False
**'****NEED HELP HERE**
'finds unit id below unique value in range 1 and inserts blank row
For Each Rng1 In WorkRng1
For Each Rng2 In WorkRng2
If Rng2.Interior.Color = VBA.RGB(255, 0, 0) And Rng2.Value > 0 Then
If Rng1.Value = Rng2.Offset(1, 0).Value Then
blkRow.Copy
Rng1.EntireRow.Insert Shift:=xlDown
Application.CutCopyMode = False
Exit For
End If
End If
Next
Next
'Error Handler
Whoa:
Select Case Err.Number
Case 1004
MsgBox "Check Your Column Letters!", vbInformation, "Oops!"
Case 424
Exit Sub
End Select
End Sub