Robinsper
01-22-2017, 09:27 PM
I'm working on a long application and I hit a wall trying to find unique records between 2 sheets and removing the row from the first sheet if the record doesn't exist in the second sheet. Here's the code I have for this section of my program, I'm a bit confuse as to how to accomplish this and I'm hoping someone will be willing to take a look and give me some suggestions, thanks.
*Explanation:
I'm looking for the unique records in column B and I'll be searching over 3000 cells in that column. If the records exist in sheet 1 but not in sheet 2 they should be deleted.
Option Explicit
Sub RemoveReversionItems()
Dim wbook As Workbook, Wsheet As Worksheet, wbName As String, wsName As String
Dim AlphaRange As Range, ReversionRange As Range
Dim AlphaArray
Dim ReversionArray
Dim x As Long
Dim AlphaSheetColumn As String: AlphaSheetColumn = "B" 'The column with the PO#
Dim ReversionSheetColumn As String: ReversionSheetColumn = "B" 'The column with the PO#
For Each wbook In Workbooks
If wbook.Name <> ActiveWorkbook.Name Then wbName = wbook.Name
Workbooks(wbName).Activate
'********************************
' Look for Reversion Queue
'********************************
For Each Wsheet In wbook.Worksheets
wsName = Wsheet.Name
If Wsheet.Name Like "Revers*" Then
MsgBox "This workbook is named " & wbName & " The Sheet is " & wsName
'Get Reversion Range
With Sheets(wsName)
Set ReversionRange = .Range(.Range(ReversionSheetColumn & "2"), _
.Range(ReversionSheetColumn & rows.Count).End(xlUp))
ReversionArray = ReversionRange
End With
End If
Next Wsheet
'*****************************
' Look for Alpha Queue
'*****************************
For Each Wsheet In wbook.Worksheets
wsName = Wsheet.Name
If Wsheet.Name Like "PO_LN*" Then
'Load Alpha WorkSheet array
With Sheets(wsName)
Set AlphaRange = .Range(.Range(AlphaSheetColumn & "2"), _
.Range(AlphaSheetColumn & rows.Count).End(xlUp))
AlphaArray = AlphaRange
End With
MsgBox "This workbook is named " & wbName & " The Sheet is " & wsName
End If
Next Wsheet
If IsArray(ReversionArray) Then
For x = UBound(ReversionArray) To 1 Step -1
If AlphaArray <> ReversionArray(x, 2) Then
ReversionRange.Cells(x).EntireRow.Interior.Color = 255 'I'll change this to delete
End If
Next
Else
End If
Next wbook
End Sub
*Explanation:
I'm looking for the unique records in column B and I'll be searching over 3000 cells in that column. If the records exist in sheet 1 but not in sheet 2 they should be deleted.
Option Explicit
Sub RemoveReversionItems()
Dim wbook As Workbook, Wsheet As Worksheet, wbName As String, wsName As String
Dim AlphaRange As Range, ReversionRange As Range
Dim AlphaArray
Dim ReversionArray
Dim x As Long
Dim AlphaSheetColumn As String: AlphaSheetColumn = "B" 'The column with the PO#
Dim ReversionSheetColumn As String: ReversionSheetColumn = "B" 'The column with the PO#
For Each wbook In Workbooks
If wbook.Name <> ActiveWorkbook.Name Then wbName = wbook.Name
Workbooks(wbName).Activate
'********************************
' Look for Reversion Queue
'********************************
For Each Wsheet In wbook.Worksheets
wsName = Wsheet.Name
If Wsheet.Name Like "Revers*" Then
MsgBox "This workbook is named " & wbName & " The Sheet is " & wsName
'Get Reversion Range
With Sheets(wsName)
Set ReversionRange = .Range(.Range(ReversionSheetColumn & "2"), _
.Range(ReversionSheetColumn & rows.Count).End(xlUp))
ReversionArray = ReversionRange
End With
End If
Next Wsheet
'*****************************
' Look for Alpha Queue
'*****************************
For Each Wsheet In wbook.Worksheets
wsName = Wsheet.Name
If Wsheet.Name Like "PO_LN*" Then
'Load Alpha WorkSheet array
With Sheets(wsName)
Set AlphaRange = .Range(.Range(AlphaSheetColumn & "2"), _
.Range(AlphaSheetColumn & rows.Count).End(xlUp))
AlphaArray = AlphaRange
End With
MsgBox "This workbook is named " & wbName & " The Sheet is " & wsName
End If
Next Wsheet
If IsArray(ReversionArray) Then
For x = UBound(ReversionArray) To 1 Step -1
If AlphaArray <> ReversionArray(x, 2) Then
ReversionRange.Cells(x).EntireRow.Interior.Color = 255 'I'll change this to delete
End If
Next
Else
End If
Next wbook
End Sub