根据两个范围内匹配的单元格值插入设置变量行

时间:2018-02-08 19:06:18

标签: excel excel-vba loops foreach vba

所以我一直在研究一些识别两个范围之间唯一值的代码。然后,我希望复制并插入选定行,它位于相对位于范围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

0 个答案:

没有答案