I have written the following code, which I was hoping to use to look up values from columns 21 through to the last row in another sheet and return them to this sheet based on a value in column A in this sheet and column B in the other sheet.
When I use the code below I get an worksheet error. Could you please tell me why?
Dim wsMvOld As Worksheet
Dim wsMvFile As Worksheet
Dim wsColumn As Long
Dim lastColumn As Long
Dim y As Integer
Dim i As Integer
Dim FrRngCount As Range
Set wsMvOld = wbMVRVFile.Worksheets(2)
wbMVRVFile.Worksheets.Add().Name = "MV " & Format(DateSerial(Year(Date), Month(Date), 0), "dd-mm-yy")
Set wsMvFile = wbMVRVFile.ActiveSheet
Set FrRngCount = wsMvFile.Range("A:A")
y = Application.WorksheetFunction.CountA(FrRngCount)
lastColumn = wsMvFile.Cells(1, wsMvFile.Columns.Count).End(xlToLeft).Column
For wsColumn = 21 To lastColumn
For i = 2 To y
wsMvFile.Columns(wsColumn).Cells(i) = Application.Index(wsMvOld.Range(wsColumn), Application.Match(wsMvFile.Range("A" & i), wsMvOld.Range("B:B"), 0))
Next i
Next wsColumn
End Sub
Thanks for your help!
This untested, but it replaces the worksheet function to vba find method.
Private Sub Worksheet_Activate()
Dim wsMvOld As Worksheet
Dim wsMvFile As Worksheet
Dim wsColumn As Long
Dim lastColumn As Long
Dim y As Integer
Dim i As Integer
Dim FrRngCount As Range
Set wsMvOld = wbMVRVFile.Worksheets(2)
Set wsMvFile = wbMVRVFile.Worksheets.Add()
wsMvFile.Name = "MV " & Format(DateSerial(Year(Date), Month(Date), 0), "dd-mm-yy")
Set FrRngCount = wsMvFile.Range("A:A")
y = Application.WorksheetFunction.CountA(FrRngCount)
lastColumn = wsMvFile.Cells(1, wsMvFile.Columns.Count).End(xlToLeft).Column
For i = 2 To y
Dim rng As Range
Set rng = sMvOld.Range("B:B").Find(wsMvFile.Range("A" & i))
For wsColumn = 21 To lastColumn
If Not rng Is Nothing Then
wsMvFile.Columns(wsColumn).Cells(i).Value = wsMvOld.Cells(rng.Row, wsColumn)
Else
wsMvFile.Columns(wsColumn).Cells(i).Value = 0
End If
Next wsColumn
Next i
End Sub
Related
I have an output excel file from another macro which has multiple sheets (named 100,101,102... etc.) Sheet numbers will vary depending on prior macro's output.
Also there is a sheet named sheet1 which has info about how many random rows should be selected from 100,101,102... etc.
I tried to merge/combine what i could find from similar macros but i guess the loop part is way over my head.
I will run the macro from another "main" excel. which will open related output xls.
Then it will lookup for random rows amount from sheet1 and then select that number of random rows in related sheet and move to next sheet. (I'm getting the correct amount from lookup (used index match))
But for randomized part i was not able to make it work for multiple sheets.
It does not matter if it selects and colors the rows or copies and pastes them to another sheet/wb. Both is ok, but I need to automate this process since i have so much data waiting.
The macro i have managed so far is below, since I'm a newbie there may be unrelated or unnecessary things.
Is it possible?
Sub RANDOM()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Sh As Worksheet
Dim Durat As Long
StartTime = Now()
Dim mvn As Workbook
Dim FPath As String
Dim newWB As Workbook
Dim SheetN As Integer
Dim I As Long
FPath = ThisWorkbook.Path
Set mvn = Workbooks.Open(FileName:=ActiveWorkbook.Path & "\" &
Sheets("Data").Range("C2").Value & " " & Sheets("Data").Range("C3").Value
& " Muavinbol" & ".xls")
SheetN = mvn.Worksheets.Count
Set SampleS = mvn.Sheets("Sheet1")
For Each Sh In mvn.Worksheets
Sh.Activate
If Sh.Name <> "Sheet1" Then
Dim lookupvalue As Integer
Dim ranrows As Integer
Dim randrows As Integer
lookupvalue = Cells(1, 1).Value
ranrows = Application.WorksheetFunction.Index(mvn.Sheets("Sheet1")_
.Range("S1:S304"), Application.WorksheetFunction.Match(lookupvalue,
mvn.Sheets("Sheet1").Range("$D$1:$D$304"), 0))
'MsgBox lookupvalue & " " & ranrows
End If
Next Sh
Durat = Round((Now() - StartTime) * 24 * 60 * 60, 0)
'MsgBox Durat & " seconds."
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Here is an example (i have integrated some code, adapted from other places, and added the references in to the code itself) I would welcome feedback from other users and can refine.
Sheet1 has the number of rows to return and the sheet names (i have used a short list)
The other sheets have some random data e.g. Sheet2
The code reads the sheet names into one array and the number of rows to randomly choose from each sheet into another array.
It then loops the sheets, generates the number of required random rows by selecting between the first and the start row in the sheet (this currently doesn't have error handling in case specified number of random rows exceeds available number ,but then could set numRows to lastRow. Union is used to collect these for the given sheet and they are copied to the next available row in the target sheet of another workbook. Union can't be used across worksheets sadly so a workaround has to be found, i chose this copy for each worksheet.
I have made some assumptions about where to copy from and to but have a play. I have also left some of your code in and currently set mnv = ThisWorkbook and the workbook to copy to is called otherWorkbook. Yours may be differently named and targeted but this was aimed at showing you a process for generating numbers and copying them in a loop.
Have used a function by Rory to test if the worksheet exists.
Example result:
Option Explicit
Public Sub RANDOM()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Sh As Worksheet
Dim Durat As Long
Dim mvn As Workbook
Dim FPath As String
Dim newWB As Workbook
'Dim SheetN As Long
Dim i As Long
Dim otherWorkbook As Workbook
Dim targetSheet As Worksheet
Dim startTime As Date
Dim mnv As Workbook
Dim SampleS As Worksheet
startTime = Now()
FPath = ThisWorkbook.Path
'Set mvn = Workbooks.Open(Filename:=ActiveWorkbook.Path & "\" & Sheets("Data").Range("C2").Value & " " & Sheets("Data").Range("C3").Value & " Muavinbol" & ".xls")
Set mnv = ThisWorkbook
Set otherWorkbook = Workbooks.Open("C:\Users\HarrisQ\Desktop\My Test Folder\Test.xlsx")
Set targetSheet = otherWorkbook.Sheets("TargetSheet")
Set SampleS = mnv.Worksheets("Sheet1")
Dim worksheetNames()
Dim numRandRows()
worksheetNames = SampleS.Range("$D$1:$D$3").Value
numRandRows = SampleS.Range("$S$1:$S$3").Value
Dim copyRange As Range
Dim currSheetIndex As Long
Dim currSheet As Worksheet
Dim selectedRows As Range
For currSheetIndex = LBound(worksheetNames, 1) To UBound(worksheetNames, 1)
If WorksheetExists(CStr(worksheetNames(currSheetIndex, 1))) Then
Set currSheet = mnv.Worksheets(worksheetNames(currSheetIndex, 1))
With currSheet
Dim firstRow As Long
Dim lastRow As Long
Dim numRows As Long
firstRow = GetFirstLastRow(currSheet, 1)(0) 'I am using Column A (1) to specify column to use to find first and last row.
lastRow = GetFirstLastRow(currSheet, 1)(1)
numRows = numRandRows(currSheetIndex, 1)
Set selectedRows = RandRows(currSheet, firstRow, lastRow, numRows) 'Union cannot span different worksheets so copy paste at this point
Dim nextTargetRow As Long
If IsEmpty(targetSheet.Range("A1")) Then
nextTargetRow = 1
Else
nextTargetRow = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row + 1
End If
selectedRows.Copy targetSheet.Cells(nextTargetRow, 1)
Set selectedRows = Nothing
End With
End If
Next currSheetIndex
Durat = Round((Now() - startTime) * 24 * 60 * 60, 0)
'MsgBox Durat & " seconds."
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Function RandRows(ByRef currSheet As Worksheet, ByVal firstRow As Long, ByVal lastRow As Long, ByVal numRows As Long) As Range
'http://www.ozgrid.com/VBA/RandomNumbers.htm
Dim iArr As Variant
Dim selectedRows As Range
Dim i As Long
Dim r As Long
Dim temp As Long
Application.Volatile
ReDim iArr(firstRow To lastRow)
For i = firstRow To lastRow
iArr(i) = i
Next i
For i = lastRow To firstRow + 1 Step -1
r = Int(Rnd() * (i - firstRow + 1)) + firstRow
temp = iArr(r)
iArr(r) = iArr(i)
iArr(i) = temp
Next i
Dim currRow As Range
For i = firstRow To firstRow + numRows - 1
Set currRow = currSheet.Cells.Rows(iArr(i))
If Not selectedRows Is Nothing Then
Set selectedRows = Application.Union(selectedRows, currRow)
Else
Set selectedRows = currRow
End If
Next i
If Not selectedRows Is Nothing Then
Set RandRows = selectedRows
Else
MsgBox "No rows were selected for copying"
End If
End Function
Private Function GetFirstLastRow(ByRef currSheet As Worksheet, ByVal colNum As Long) As Variant
'colNum determine which column you will use to find last row
Dim startRow As Long
Dim endRow As Long
endRow = currSheet.Cells(currSheet.Rows.Count, colNum).End(xlUp).Row
startRow = FirstUsedCell(currSheet, colNum)
GetFirstLastRow = Array(startRow, endRow)
End Function
Private Function FirstUsedCell(ByRef currSheet As Worksheet, ByVal colNum As Long) As Long
'Finds the first non-blank cell in a worksheet.
'https://www.excelcampus.com/library/find-the-first-used-cell-vba-macro/
Dim rFound As Range
On Error Resume Next
Set rFound = currSheet.Cells.Find(What:="*", _
After:=currSheet.Cells(currSheet.Rows.Count, colNum), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
On Error GoTo 0
If rFound Is Nothing Then
MsgBox currSheet & ":All cells are blank."
End
Else
FirstUsedCell = rFound.Row
End If
End Function
Function WorksheetExists(sName As String) As Boolean
'#Rory https://stackoverflow.com/questions/6688131/test-or-check-if-sheet-exists
WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function
Since QHarr's code needed to have all worksheet names should exist in the workbook did not work for me in the end. But with merging it some other project's function i made it work.
Opens an output xlsx file in same folder,
Index&Match to find the random rows amount
loop through all sheets with random function
then paste all randomized rows into Sheet named RASSAL
It may be unefficient since I really dont have much info on codes, but guess i managed to modify it into my needs.
Open to suggestions anyway and thanks to #QHarr very much for His/Her replies.
Sub RASSALFNL()
'Application.ScreenUpdating = False
'Application.DisplayAlerts = False
Dim Durat As Long
startTime = Now()
Dim Sht As Worksheet
Dim mvn As Workbook
Dim FPath As String
Dim newWB As Workbook
Dim SheetN As Long
Dim i As Long
Dim lookupvalue As Long
Dim indexrange As Range
Dim matchrange As Range
Dim ranrows As Long
Dim firstRow As Long
Dim lastRow As Long
Dim numRows As Long
Dim sayf As String
Dim nextTargetRow As Long
Dim Rassal As Worksheet
Dim rngToCopy As Range
Dim sampleCount As Long
Dim ar() As Long
Dim total As Long
Dim rowhc As Long
FPath = ThisWorkbook.Path
Set mvn = Workbooks.Open(FileName:=ActiveWorkbook.Path & "\" &
Sheets("Data").Range("C2").Value & " " & Sheets("Data").Range("C3").Value
& " Muavinbol" & ".xlsx")
SheetN = mvn.Worksheets.count
Set SampleS = mvn.Sheets("Sheet1")
Set Rassal = Worksheets.Add
Rassal.Name = "RASSAL"
Set indexrange = SampleS.Range("$S$8:$S$304")
Set matchrange = SampleS.Range("$D$8:$D$304")
mvn.Activate
For Each Sht In mvn.Worksheets
Sht.Activate
If Sht.Name = "Sheet1" Or Sht.Name = "Sayfa1" Or Sht.Name = "RASSAL"
Then
'do nothing
Else
lookupvalue = Sht.Cells(1, 1).Value
ranrows = Application.WorksheetFunction.Index(indexrange,
Application.WorksheetFunction.Match(lookupvalue, matchrange, 0))
With Sht
firstRow = GetFirstLastRow(Sht, 1)(0)
lastRow = GetFirstLastRow(Sht, 1)(1)
numRows = ranrows
sayf = Sht.Name
'MsgBox sayf & " " & firstRow & " " & lastRow & " " &
ranrows
If numRows = 0 Then
'do nothing
Else
ar = UniqueRandom(numRows, firstRow, lastRow)
Set rngToCopy = .Rows(ar(0))
For i = 1 To UBound(ar)
Set rngToCopy = Union(rngToCopy, .Rows(ar(i)))
Next
If IsEmpty(mvn.Sheets("RASSAL").Range("A1")) Then
nextTargetRow = 1
Else
nextTargetRow =
mvn.Sheets("RASSAL").Cells(mvn.Sheets("RASSAL").Rows.count,
"A").End(xlUp).Row + 1
End If
rngToCopy.Copy Rassal.Cells(nextTargetRow, 1)
Set rngToCopy = Nothing
End If
End With
End If
Next Sht
rowhc = Rassal.Cells(Rows.count, 1).End(xlUp).Row
Durat = Round((Now() - startTime) * 24 * 60 * 60, 0)
MsgBox rowhc & " " & "random selections made in" & " " & Durat & "
seconds."
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Function GetFirstLastRow(ByRef Sht As Worksheet, ByVal colNum As
Long) As Variant
'colNum determine which column you will use to find last row
Dim firstRow As Long
Dim lastRow As Long
lastRow = Sht.Cells(Sht.Rows.count, colNum).End(xlUp).Row
firstRow = FirstUsedCell(Sht, colNum)
GetFirstLastRow = Array(firstRow, lastRow)
End Function
Private Function FirstUsedCell(ByRef Sht As Worksheet, ByVal colNum As
Long) As Long
Dim rFound As Range
On Error Resume Next
Set rFound = Sht.Cells.Find(What:="*", _
After:=Sht.Cells(Sht.Rows.count,
colNum), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
On Error GoTo 0
If rFound Is Nothing Then
'do Nothing MsgBox Sh & ":All cells are blank."
End
Else
FirstUsedCell = rFound.Row
End If
End Function
Function UniqueRandom(ByVal numRows As Long, ByVal a As Long, ByVal b As
Long) As Long()
Dim i As Long, j As Long, x As Long
ReDim arr(b - a) As Long
Randomize
For i = 0 To b - a: arr(i) = a + i: Next
If b - a < count Then UniqueRandom = arr: Exit Function
For i = 0 To b - a 'Now we shuffle the array
j = Int(Rnd * (b - a))
x = arr(i): arr(i) = arr(j): arr(j) = x ' swap
Next
' After shuffling the array, we can simply take the first portion
If numRows = 0 Then
ReDim Preserve arr(0)
Else
ReDim Preserve arr(0 To numRows - 1)
On Error Resume Next
End If
'sorting, probably not necessary
For i = 0 To count - 1
For j = i To count - 1
If arr(j) < arr(i) Then x = arr(i): arr(i) = arr(j): arr(j) = x '
swap
Next
Next
UniqueRandom = arr
End Function
I cannot paste anywhere besides column "A" I have tried changing the column letter, but I get an error code saying the "copy/paste cell are not the same size".
Sub HEA_Filter_Names()
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean
strArray = Array("ack-")
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = Sheets("Real Alarms")
For I = 1 To NoRows
Set rngCells = wsSource.Range("B" & I)
Found = False
For J = 0 To UBound(strArray)
Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
Next J
If Found Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub
You cannot paste an EntireRow starting anywhere else than column A.
You can try this instead:
Intersect(rngCells.EntireRow, rngCells.Parent.UsedRange).Copy wsDest.Range("F" & DestNoRows)
I have written the following code which is supposed to run through a data set and delete all rows that do not match the value in call C1. In my original code I deleted line by line and the code was very slow, so now I am trying to add all values to a variant and delete all cells at the end. Is this possible?
Sub FixData()
Dim wbFeeReport As Workbook
Dim wsData As Worksheet
Dim wsData2 As Worksheet
Dim FrRngCount As Range
Dim x As Long
Dim y As Long
Dim varRows As Variant
Set wbFeeReport = ThisWorkbook
Set wsData = wbFeeReport.Worksheets("Data")
Set wsData2 = wbFeeReport.Worksheets("Data2")
Set FrRngCount = wsData.Range("D:D")
y = Application.WorksheetFunction.CountA(FrRngCount)
For x = y To 2 Step -1
If wsData.Range("J" & x).Value <> wsData2.Range("C1").Value Then
varRows = x
Else
wsData.Range("AF" & x).Value = wsData.Range("J" & x).Value
End If
Next x
wsData.Rows(varRows).EntireRow.Delete
End Sub
Right now the code only deletes the last row as the variant is overwritten each time as it runs through the loop. Any suggestions on how I can store all values in the variant and delete the rows I don't need at the end?
Thanks for you help!
The fastest way is to
Load the data into an array
Copy the valid data into a second array
Clear the contents of the range
Write the second array back to the worksheet
Sub FixData()
Dim Source As Range
Dim Data, Data1, TargetValue
Dim x As Long, x1 As Long, y As Long
Set Source = Worksheets("Data").Range("A1").CurrentRegion
TargetValue = Worksheets("Data2").Range("C1")
Data = Source.Value
ReDim Data1(1 To UBound(Data, 1), 1 To UBound(Data, 2))
For x = 1 To UBound(Data, 1)
If x = 1 Or Data(x, 10) = TargetValue Then
x1 = x1 + 1
For y = 1 To UBound(Data, 2)
Data1(x1, y) = Data(x, y)
Next
End If
Next
Source.ClearContents
Source.Resize(x1).Value = Data1
End Sub
As you need a range holding all rows, you can collect it in one "on the run" like this:
Sub FixData()
Dim wsData As Worksheet
wsData = ThisWorkbook.Worksheets("Data")
Dim val As Variant
val = ThisWorkbook.Worksheets("Data2").Range("C1").Value
Dim DelRows As Range, x As Long
For x = 2 To wsData.Cells(wsData.Rows.Count, 4).End(xlUp).Row
If wsData.Range("J" & x).Value <> val Then
If DelRows Is Nothing Then
Set DelRows = wsData.Rows(x)
Else
Set DelRows = Union(wsData.Rows(x), DelRows)
End If
Else
wsData.Range("AF" & x).Value = wsData.Range("J" & x).Value
End If
Next x
DelRows.EntireRow.Delete
End Sub
I have a spreadsheet that has values for more than one month, so I am trying to first find the value based on a value in the wsRevFile worksheet and then ensure that this is the value from last month. When I use the following code, I get a "invalid number of arguments" error.
Sub RevLookup(wsMvFile As Worksheet, wsRevOld As Worksheet, wsNewRev As Worksheet, _
rowCount As Integer, workCol As String, _
srcCol1 As Integer, srcCol2 As Integer)
Dim vrw As Variant, i As Long
For i = 2 To rowCount
vrw = Application.Match(wsRevFile.Range("A" & i), wsNewRev.Columns(2), Format(DateSerial(Year(Date), Month(Date), 0), "mm/dd/yyyy"), wsNewRev.Columns(1), 0)
If IsError(vrw) Then
vrw = Application.Match(wsRevFile.Range("A" & i), wsRevOld.Columns(1), 0)
If Not IsError(vrw) Then _
wsRevFile.Range(workCol & i) = Application.Index(wsRevOld.Columns(srcCol1), vrw)
Else
wsRevFile.Range(workCol & i) = Application.Index(wsNewRev.Columns(srcCol2), vrw, 1)
End If
Next i
End Sub
I am assuming this has to do with the way I assigned the Application Match function, because the formula without this part works for other columns. Any ideas on how I could get this to work?
Thanks for your help!
Try ajusting the variables of the following procedure, as I didn't figure out your input and output data:
Sub Main()
Dim SearchValue As Variant
Dim SearchColumn As Range
Dim ReturnColumn As Range
Dim ResultRows As Collection
Dim LastDate As Variant 'Date?
Dim iRow As Variant
SearchValue = 10 '<-- change to suit
Set SearchColumn = wsNewRev.Range("B1:B10")
Set ReturnColumn = wsNewRev.Range("C1:C10") '<-- change to suit
Set ResultRows = GetLoopRows(SearchColumn, SearchValue)
For Each iRow In ResultRows
If LastDate < ReturnColumn(iRow) Then
LastDate = ReturnColumn(iRow)
End If
Next iRow
Debug.Print LastDate
End Sub
Function GetLoopRows(ParamArray pParameters() As Variant) As Collection
'Obtém limites de laços com levando em conta condições
'[vetor1], [valor1], [vetor2], [valor2], ...
Dim iCondition As Long
Dim i As Variant
Dim iRow As Variant
Dim Result As Collection
Dim NumConditions As Long
Dim SearchCollection As Collection
Dim ArraysCollection As Collection
Dim iArray As Variant
NumConditions = (UBound(pParameters) - LBound(pParameters) + 1) / 2
Set ArraysCollection = New Collection
Set SearchCollection = New Collection
For i = LBound(pParameters) To UBound(pParameters) Step 2
ArraysCollection.Add pParameters(i + 0).Value2
SearchCollection.Add pParameters(i + 1)
Next i
Set Result = New Collection
For iRow = LBound(ArraysCollection(1)) To UBound(ArraysCollection(1))
For iCondition = 1 To NumConditions
If ArraysCollection(iCondition)(iRow, 1) <> SearchCollection(iCondition) Then GoTo Continue
Next iCondition
Result.Add CLng(iRow)
Continue:
Next iRow
Quit:
Set GetLoopRows = Result
End Function
I have 2 separate sheets, lets call them sheet A, sheet B. I have data in sheet B which is also in sheet A. I want to find those rows that are equal and remove them from sheet B.
I cannot combine the 2 sheets and use filters because I'm doing dynamic SQL to query different data.
Each sheet has a unique key column
I'm ok with VBA suggestions and Excel formulas. Just as long as I don't combine sheets.
Thank so much guys!
Sorry, apparently I made a mistake. There is an infinite loop here somewhere. This is Ben's answer btw. I just reposted a compilable version.
Sub CleanDupes()
Dim wsA As Worksheet
Dim wsB As Worksheet
Dim keyColA As String
Dim keyColB As String
Dim rngA As Range
Dim rngB As Range
Dim intRowCounterA As Integer
Dim intRowCounterB As Integer
keyColA = "A"
keyColB = "A"
intRowCounterA = 1
intRowCounterB = 1
Set wsA = Worksheets("Sheet2")
Set wsB = Worksheets("Sheet1")
Do While Not IsEmpty(wsA.Range(keyColA & intRowCounterA).Value)
Set rngA = wsA.Range(keyColA & intRowCounterA)
intRowCounterB = 1
Do While Not IsEmpty(wsB.Range(keyColB & intRowCounterB).Value)
Set rngB = wsB.Range(keyColB & intRowCounterB)
If rngA.Value = rngB.Value Then
Rows(intRowCounterB).EntireRow.Delete
intRowCounterB = intRowCounterB - 1
End If
intRowCounterB = intRowCounterB + 1
Loop
intRowCounterA = intRowCounterA + 1
Loop
End Sub
Sub CleanDupes()
Dim wsA As Worksheet
Dim wsB As Worksheet
Dim keyColA As String
Dim keyColB As String
Dim rngA As Range
Dim rngB As Range
Dim intRowCounterA As Integer
Dim intRowCounterB As Integer
Dim strValueA As String
keyColA = "A"
keyColB = "B"
intRowCounterA = 1
intRowCounterB = 1
Set wsA = Worksheets("Sheet A")
Set wsB = Worksheets("Sheet B")
Do While Not IsEmpty(wsA.Range(keyColA & intRowCounterA).Value)
intRowCounterB = 1
Set rngA = wsA.Range(keyColA & intRowCounterA)
strValueA = rngA.Value
Do While Not IsEmpty(wsB.Range(keyColB & intRowCounterB).Value
Set rngB = wsB.Range(keyColB & intRowCounterB)
If strValueA = rngB.Value Then
'Code to delete row goes here, but I'm not sure exactly'
'what it is.'
wsB.Rows(intRowCounterB).Delete
intRowCounterB = intRowCounterB - 1
End If
intRowCounterB = intRowCounterB + 1
Loop
intRowCounterA = intRowCounterA + 1
Loop
End Sub
That should get you started.