excel vba step thru rows faster - excel

the code below works 100%. It scans for a match in Column B and copies and renames a group of cells when a match is found. However the is a line For lRow = Sheets("HR-Calc").Cells(Cells.Rows.count, "b").End(xlUp).Row To 7 Step -1
Where the step -1 will scan row by row from the bottom of the sheet until a match is found. It would be much easier if the step was set to End.(xlUp) instead of -1. searching every row is overkill because of how the data is set up End.(xlUp) would massive cut down the run time.
Is something like this possible?
Sub Fill_CB_Calc()
M_Start:
Application.ScreenUpdating = True
Sheets("summary").Activate
d_input = Application.InputBox("select first cell in data column", "Column Data Check", Default:="", Type:=8).Address(ReferenceStyle:=xlA1, RowAbsolute:=True, ColumnAbsolute:=False)
data_col = Left(d_input, InStr(2, d_input, "$") - 1)
data_row = Right(d_input, Len(d_input) - InStr(2, d_input, "$"))
Application.ScreenUpdating = False
Sheets("summary").Activate
Range(d_input).End(xlDown).Select
data_last = ActiveCell.Row
If IsEmpty(Range(data_col & data_row + 1)) = True Then
data_last = data_row
Else
End If
For j = data_row To data_last
CBtype = Sheets("summary").Range(data_col & j)
Sheets("HR-Calc").Activate
For lRow = Sheets("HR-Calc").Cells(Cells.Rows.count, "b").End(xlUp).Row To 7 Step -1
If Sheets("HR-Calc").Cells(lRow, "b") = CBtype Then
CBend = Sheets("HR-Calc").Range("C" & lRow).End(xlDown).Row + 1
Sheets("HR-Calc").Rows(lRow & ":" & CBend).Copy
CBstart = Sheets("HR-Calc").Range("c50000").End(xlUp).Row + 2
ActiveWindow.ScrollRow = CBstart - 8
Sheets("HR-Calc").Range("A" & CBstart).Insert Shift:=xlDown
CBold = Right(Range("c" & CBstart), Len(Range("C" & CBstart)) - 2)
box_name = Sheets("summary").Range(data_col & j).Offset(0, -10)
CBnew = Right(box_name, Len(box_name) - 2) & "-" ' <--this is custom and can be changed based on CB naming structure
If CBnew = "" Or vbCancel Then
End If
CBend2 = Range("c50000").End(xlUp).Row - 2
Range("C" & CBstart + 1 & ":" & "C" & CBend2).Select
Selection.Replace What:=CBold & "-", Replacement:=CBnew, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("C" & CBstart).FormulaR1C1 = "CB" & Left(CBnew, Len(CBnew) - 1)
GoTo M_Start2
Else
End If
Next lRow
M_Start2:
Next j
YN_result = MsgBox("Fill info for another block/inverter?", vbYesNo + vbExclamation)
If YN_result = vbYes Then GoTo M_Start
If YN_result = vbNo Then GoTo jumpout
jumpout:
' Sheets("summary").Range(d_input).Select
Application.ScreenUpdating = True
End Sub

I'm not sure if this will help but I've had a great performance increase with pulling the entire range you need to loop through into a variant array and then looping through the array. If I need to loop through large data sets, this method has worked out well.
Dim varArray as Variant
varArray = Range(....) 'set varArray to the range you're looping through
For y = 1 to uBound(varArray,1) 'loops through rows of the array
'code for each row here
'to loop through individual columns in that row, throw in another loop
For x = 1 to uBound(varArray, 2) 'loop through columns of array
'code here
Next x
Next y
You can also define the column indexes prior to executing the loop. Then you only need to execute the you need to pull those directly in the loop.
'prior to executing the loop, define the column index of what you need to look at
Dim colRevenue as Integer
colRevenue = 5 'or a find function that searches for a header named "Revenue"
Dim varArray as Variant
varArray = Range(....) 'set varArray to the range you're looping through
For y = 1 to uBound(varArray,1) 'loops through rows of the array
tmpRevenue = CDbl(varArray(y, colRevenue))
Next y
Hope this helps.

Look at doing a .find from the bottom up.
Perform a FIND, within vba, from the bottom of a range up
That will eliminate the need to do the for loop from the last row to the first occurrence of the value you want to locate.

Related

Can I make my VBA code work Faster? it currently takes 7 minutes to look through 1300 rows and 500 columns

Variance Table Sample I'm working on an Excel Macros (VBA) to look through every 3rd cell of each row in a data set and perform a copy paste action based on conditions (Please see the code at the bottom).
The source data is in a another worksheet (Variance). It has 1300+ IDs (rows) and 3 columns for each value component (col 1 - value 1, col 2 - value 2, and col 3 - the difference between the 2 values) and likewise there are 500+ columns.
My code basically looks through every third column (the difference column) of each row to find out if the value is a number, not equal to zero, and if it's not an error (there are errors in the source sheet). If yes, it copies the Emp ID, the column Name, and both the values into another worksheet called vertical analysis (one below the other).
The code works fine, but it takes 6 to 7 minutes for a data set with 1000+ rows and 500+ columns.
Can someone please tell me if there is a faster way to do this than to loop through each row?
Please let me know if you need more information. Thanks in advance.
Code:
Sub VerticalAnalysis()
Dim EmpID As Range
Dim i As Long
Dim cell As Range
Dim lastrow As Range
Dim LastCol As Long
Dim curRow As Long
Dim c As Long
Set lastrow = ThisWorkbook.Worksheets("Variance").Cells(Rows.Count, 2).End(xlUp)
Set EmpID = ThisWorkbook.Worksheets("Variance").Range("B4", lastrow)
LastCol = ThisWorkbook.Worksheets("Variance").Cells(3, Columns.Count).End(xlToLeft).Column
Application.ScreenUpdating = False
MsgBox "Depending on the size of the record, your excel will not respond for several minutes during Vertical Analysis. Please don't close the workbook", , "Note: Please Don't Close the Workbook"
Worksheets("Vertical").Select
Range("B3", "H" & Rows.Count).ClearContents
Range("B3", "H" & Rows.Count).ClearFormats
ThisWorkbook.Worksheets("Variance").Select
c = 1
For Each cell In EmpID
i = 2
Do Until i >= LastCol
cell.Offset(0, i).Select
If IsError(ActiveCell) Then
ElseIf ActiveCell <> "" Then
If IsNumeric(ActiveCell) = True Then
If ActiveCell <> 0 Then
cell.Copy
Worksheets("Vertical").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(-c, -2).Copy
Worksheets("Vertical").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(0, -2).Copy
Worksheets("Vertical").Range("D" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(0, -1).Copy
Worksheets("Vertical").Range("E" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
End If
End If
i = i + 4
Loop
c = c + 1
Next cell
ThisWorkbook.Worksheets("Vertical").Select
Range("B2").Select
MsgBox "Analysis complete " & vbCrLf & Worksheets("Vertical").Range("B" & Rows.Count).End(xlUp).Row - 2 & " Components have variations", , "Success!"
Application.ScreenUpdating = True
End Sub
You might try to use SQL. In order to learn how to use sql in EXCEL VBA, I suggest you to follow this tuto and to apply your learn on your macro. They will be faster =)
https://analystcave.com/excel-using-sql-in-vba-on-excel-data/
Better not to hit the sheet so many times.
Below is tested and should run in a few seconds, but you may need to tweak the column positions etc:
Sub VerticalAnalysis()
Const BLOCK_SIZE As Long = 30000
Dim lastrow As Long
Dim LastCol As Long
Dim c As Long, wsVar As Worksheet, wsVert As Worksheet, n As Long
Dim data, r As Long, empId, v, rwVert As Long, dataVert, i As Long
Set wsVar = ThisWorkbook.Worksheets("Variance")
Set wsVert = ThisWorkbook.Worksheets("Vertical")
lastrow = wsVar.Cells(Rows.Count, 2).End(xlUp).Row
LastCol = wsVar.Cells(3, Columns.Count).End(xlToLeft).Column
'get all the input data as an array (including headers)
data = wsVar.Range("A3", wsVar.Cells(lastrow, LastCol)).Value
'clear the output sheet and set up the "transfer" array
With wsVert.Range("B3", "H" & Rows.Count)
.ClearContents
.ClearFormats
End With
rwVert = 3 'first "vertical" result row
ReDim dataVert(1 To BLOCK_SIZE, 1 To 4) 'for collecting matches
i = 0
n = 0
For r = 2 To UBound(data, 1) 'loop rows of input array
empId = data(r, 2) 'colB ?
c = 7 'first "difference" column ?
Do While c <= UBound(data, 2)
v = data(r, c)
If Not IsError(v) Then
If IsNumeric(v) Then
If v > 0.7 Then
i = i + 1
n = n + 1
dataVert(i, 1) = empId
dataVert(i, 2) = data(1, c) 'header
dataVert(i, 3) = data(r, c + 2) 'value1
dataVert(i, 4) = data(r, c + 1) 'value2
'have we filled the temporary "transfer" array?
If i = BLOCK_SIZE Then
wsVert.Cells(rwVert, 2).Resize(BLOCK_SIZE, 4).Value = dataVert
i = 0
ReDim dataVert(1 To BLOCK_SIZE, 1 To 4)
rwVert = rwVert + BLOCK_SIZE
End If
End If
End If
End If
c = c + 4 'next difference
Loop
Next r
'add any remaining
If i > 0 Then wsVert.Cells(rwVert, 2).Resize(BLOCK_SIZE, 4).Value = dataVert
wsVert.Select
wsVert.Range("B2").Select
MsgBox "Analysis complete " & vbCrLf & n & " Components have variations", , "Success!"
End Sub

Deleteing all rows without information in columns B-G

I am trying to create a program that deletes all rows without information in columns B-G and then rearranges the data from a vertical orientation to a horizontal one.
The data is only in columns A-G arranged so that every couple rows (the number is not constant), a row of dates appears. I want every row with dates to be pasted horizontally from each other and all of the data in between the dates to move corresponding with their dates (including column A).
The part that deletes empty rows works well. However, as I tried to write the rearrangement program, I kept on getting an
"Object Required"
error that appeared in the sub line (AKA the first line). Can someone help me resolve this issue? The code is pasted below.
Sub MovingDeletion()
Set rngRange = Selection.CurrentRegion
lngNumRows = rngRange.Rows.Count
lngFirstRow = rngRange.Row
lngLastRow = lngFirstRow + lngNumRows - 1
columns("B").Select
lngCompareColumn1 = ActiveCell.Column
columns("C").Select
lngCompareColumn2 = ActiveCell.Column
columns("D").Select
lngCompareColumn3 = ActiveCell.Column
columns("E").Select
lngCompareColumn4 = ActiveCell.Column
columns("F").Select
lngCompareColumn5 = ActiveCell.Column
columns("G").Select
lngCompareColumn6 = ActiveCell.Column
columns("A").Select
lngCompareColumn7 = ActiveCell.Column
Set MedicationRow = 0
'Deletion Code (Works Fine)
For lngCurrentRow = lngLastRow To lngFirstRow Step -1
Mrow = True
If (Cells(lngCurrentRow, lngCompareColumn1).Text = "" And Cells(lngCurrentRow, lngCompareColumn2).Text = "" And Cells(lngCurrentRow, lngCompareColumn3).Text = "" And Cells(lngCurrentRow, lngCompareColumn4).Text = "" And Cells(lngCurrentRow, lngCompareColumn5).Text = "" And Cells(lngCurrentRow, lngCompareColumn6).Text = "") Then _
Rows(lngCurrentRow).Delete
'Rearrangement Code (Does not work. Gives Object Requiered error)
Dim counter As Integer
Dim NextRow As Integer
Dim i As Integer
i = lngCurrentRow
counter = 0
Number = 0
If (Cells(lngCurrentRow, lngCompareColumn7).Text <> "Days") Then
counter = counter + 1
If counter > 1 Then
NextRow = lngCurrentRow - 1
While (Cells(NextRow, lngCompareColumn7).Text <> "Days")
NextRow = NextRow - 1
Number = Number + 1
Wend
End If
Range("A" & CStr(i) & ":G" & CStr(NextRow)).Cut Range("H1" & CStr(i) & ":P" & CStr(NextRow))
End If
Next lngCurrentRow
End Sub

Filter out entire rows if group value is below 10

I am trying to remove rows from a spreadsheet in VBA if the sum total of value exceeds a specific amount.
For example, if I have the following data, names in A1 down and values in A2 down:
I would like to remove all rows where the total sum of the value in row A does not reach 10 or above in row B, this would leave the following results:
Thomas = 18 and John = 15 so all rows with Thomas and John are kept.
All other rows would be deleted.
Please note that I will always know that the data is in row A and B but I do not know how many rows there will be and need to execute until the first blank cell.
It worked. You can see this here:
Sub run()
Dim rowIndex, countSameRow, sumSameRow As Integer
sumSameRow = Cells(1, 2)
rowIndex = 2
countSameRow = 1
While IsEmpty(Cells(rowIndex, 1)) = False
If (Cells(rowIndex, 1) = Cells(rowIndex - 1, 1)) Then
sumSameRow = sumSameRow + Cells(rowIndex, 2)
countSameRow = countSameRow + 1
Else
If (sumSameRow < 10) Then
Rows(rowIndex - 1 & ":" & rowIndex - countSameRow).Delete
rowIndex = rowIndex - countSameRow
End If
countSameRow = 1
sumSameRow = Cells(rowIndex, 2)
End If
If IsEmpty(Cells(rowIndex + 1, 1)) Then
If (sumSameRow < 10) Then
Rows(rowIndex & ":" & rowIndex - countSameRow + 1).Delete
End If
End If
rowIndex = rowIndex + 1
Wend
End Sub
Totally agree you should write your own code first, but I couldn't help but write some starting code for you. See if the below fits your purpose:
Sub Test()
Dim lr As Long, x As Long
Dim arr As Variant, rng As Range
Dim dict1 As Object: Set dict1 = CreateObject("Scripting.Dictionary")
Dim dict2 As Object: Set dict2 = CreateObject("Scripting.Dictionary")
With Sheet1 'Change according to your sheets CodeName
'Get all of your data form A:B in memory (array)
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("A1:B" & lr)
'Step through the array and fill up our two dictionaries
For x = LBound(arr) To UBound(arr)
If dict1(arr(x, 1)) <> "" Then
dict1(arr(x, 1)) = Join(Array(dict1(arr(x, 1)), x & ":" & x), ",")
Else
dict1(arr(x, 1)) = x & ":" & x
End If
dict2(arr(x, 1)) = dict2(arr(x, 1)) + arr(x, 2)
Next x
'Step through our second dictionary and check if value < 10
For Each Key In dict2.keys
If dict2(Key) < 10 Then
If Not rng Is Nothing Then
Set rng = Union(rng, .Range(dict1(Key)))
Else
Set rng = .Range(dict1(Key))
End If
End If
Next Key
'If any where below 10, this Range object has been filled, so delete it.
If Not rng Is Nothing Then
rng.Delete
End If
End With
End Sub
Here is another method that uses Autofilter and SUMIF to delete the lines.
This assumes there is a header row, if not then add a row first.
It adds a sumif in column C and filters all that is less than 10, then deletes them.
Then removes column C again.
Sub filter()
Range("C1").Value = "Sum"
Lastrow = Range("A" & Rows.Count).End(xlUp).Row
Range("C2:C" & Lastrow).Formula = "=sumif(A:A,A2,B:B)"
Range("A2").AutoFilter ' add a filter to table
ActiveSheet.Range("$A$1:$C$" & Lastrow).AutoFilter Field:=3, Criteria1:="<10", Operator:=xlAnd ' filter all below 10
ActiveSheet.Range("A2:C" & Lastrow).SpecialCells(xlCellTypeVisible).EntireRow.Delete ' delete them
Range("A1").AutoFilter ' remove filter again
Columns("C:C").EntireColumn.Delete ' remove column C
End Sub

How to delete an entire row from a table in excel only if multiple cells are empty in that row? (VBA)

I Have 10 columns in an Excel table, and I want to delete the rows where the first 7 cell is empty.
I've tried to do it this way:
Sheet1.Range("Table4[variable1, variable2, variable3, variable4, variable5, variable6, variable7]").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
but It doesn't work. Am I have to use nested for loop for rows and columns?
You can loop trough each row directly, and check if the first 7 cells of that row in your table are empty. If true, delete them.
Dim MyTable As ListObject
Dim i As Long
Set MyTable = ActiveSheet.ListObjects("Table4")
With MyTable.DataBodyRange
For i = .Rows.Count To 1 Step -1
If Application.WorksheetFunction.CountBlank(.Range(Cells(i, 1), Cells(i, 7))) = 7 Then .Rows(i).Delete
Next i
End With
The good point about this way is that if your table changes address, it still will work. You would only need to update if you want to check a different name of cells (seven rght now) or if the condition (7 first cells empty) changes.
Broadly speaking yes. Loop down the rows you want to check,
For rowcounter = 1 to 10 'whatever rows you want
use the test
If Application.WorksheetFunction.CountA("A" & rowcounter & ":G" & rowcounter) = 0 Then
(I assume first 7 columns meant A to G), and then
Rows(rowcounter).Delete
You don't need multiple loops. A single loop with the use of the IsEmpty() function should work:
Option Explicit
Sub Test()
Dim i As Long
For i = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row To 1 Step -1
If IsEmpty(Sheet1.Cells(i,1)) And IsEmpty(Sheet1.Cells(i,2)) And IsEmpty(Sheet1.Cells(1,3)) And _
IsEmpty(Sheet1.Cells(i,4)) And IsEmpty(Sheet1.Cells(i,5)) And _
IsEmpty(Sheet1.Cells(i,6)) And IsEmpty(Sheet1.Cells(i,7)) Then
Sheet1.Rows(i).Delete
End If
Next i
End Sub
I guess that this simple snippet, full of unnecessary procedures, can help you:
Sub NotTested()
' Choose below the rows range
first_row = 2
last_row = 4242
For r = last_row To first_row Step -1
' Checking below each column (from row r) value
a_value = ThisWorkbook.Sheets("Sheet1").Cells(r, 1).Value2
b_value = ThisWorkbook.Sheets("Sheet1").Cells(r, 2).Value2
c_value = ThisWorkbook.Sheets("Sheet1").Cells(r, 3).Value2
d_value = ThisWorkbook.Sheets("Sheet1").Cells(r, 4).Value2
e_value = ThisWorkbook.Sheets("Sheet1").Cells(r, 5).Value2
f_value = ThisWorkbook.Sheets("Sheet1").Cells(r, 6).Value2
g_value = ThisWorkbook.Sheets("Sheet1").Cells(r, 7).Value2
' Comparing if the columns are actually empty
If a_value = "" And b_value = "" And c_value = "" And d_value = "" And e_value = "" And f_value = "" And g_value = "" Then
ThisWorkbook.Sheets("Sheet1").Cells(r, 1).EntireRow.Delete
End If
Next r
End Sub
Here's a simple solution that actually counts the number of rows in a table then deletes if the first 7 columns are blank.
Sub deleteEmptyRows()
Set tbl = ActiveSheet.ListObjects("Table4")
For I = 1 To tbl.Range.Rows.Count
If WorksheetFunction.CountA(Range("A" & I & ":" & "G" & I)) = 0 Then
Sheets("Sheet1").Rows(I).EntireRow.Delete
End If
Next I
End Sub

Removing duplicates based on their occurrence

I would like to check a certain column (W) for duplicates (number of occurrences is stored in another column (AZ)) and than delete all row this way:
Value is found two times in the column - delete only one row containing the value.
Value is found more times in the column - delete all the rows with the values.
My code works quite well but sometimes it doesn't delete all the duplicates as it should do. Any idea for improvement?
EDIT: The updated code works really good except that it always misses one duplicate and leaves it not deleted.
fin = ws.UsedRange.Rows.count
For i = 2 To fin
ws.Range("AZ" & i).value = Application.WorksheetFunction.CountIf(ws.Range("W2:W" & fin), ws.Range("W" & i))
Next i
For j = fin To 2 Step -1
If ws.Range("AZ" & j).value > 2 Then
ws.Range("AZ" & j).EntireRow.Delete
fin = ws.UsedRange.Rows.count
ElseIf ws.Range("AZ" & j).value = 2 Then
Set rng = Range("W:W").Find(Range("W" & j).value, , xlValues, xlWhole, , xlNext)
rngRow = rng.Row
If rngRow <> j Then
ws.Range("AZ" & rngRow) = "1"
ws.Range("AZ" & j).EntireRow.Delete
fin = ws.UsedRange.Rows.count
Else
MsgBox "Error at row " & rngRow
End If
End If
Next j
If speed is an issue, here is a method that should be faster, as it creates a collection of rows to be deleted, then deletes them. Since everything, except for the actual row deletion, is done in VBA, there are far fewer calls back and forth to the worksheet.
The routine could be sped up as noted in the inline comments.
If it is still too slow, depending on the size of the worksheet, it might be feasible to read the entire worksheet into a VBA Array; test for duplicates; write back the results to a new array and write that out to the worksheet. (If your worksheet is too large, this method might run out of memory, though).
In any event, we need both a Class Module which YOU must rename cPhrases, as well as a Regular Module
Class Module
Option Explicit
Private pPhrase As String
Private pCount As Long
Private pRowNums As Collection
Public Property Get Phrase() As String
Phrase = pPhrase
End Property
Public Property Let Phrase(Value As String)
pPhrase = Value
End Property
Public Property Get Count() As Long
Count = pCount
End Property
Public Property Let Count(Value As Long)
pCount = Value
End Property
Public Property Get RowNums() As Collection
Set RowNums = pRowNums
End Property
Public Function ADDRowNum(Value As Long)
pRowNums.Add Value
End Function
Private Sub Class_Initialize()
Set pRowNums = New Collection
End Sub
Regular Module
Option Explicit
Sub RemoveDuplicateRows()
Dim wsSrc As Worksheet
Dim vSrc As Variant
Dim CP As cPhrases, colP As Collection, colRowNums As Collection
Dim I As Long, K As Long
Dim R As Range
'Data worksheet
Set wsSrc = Worksheets("sheet1")
'Read original data into VBA array
With wsSrc
vSrc = .Range(.Cells(1, "W"), .Cells(.Rows.Count, "W").End(xlUp))
End With
'Collect list of items, counts and row numbers to delete
'Collection object will --> error when trying to add
' duplicate key. Use that error to increment the count
Set colP = New Collection
On Error Resume Next
For I = 2 To UBound(vSrc, 1)
Set CP = New cPhrases
With CP
.Phrase = vSrc(I, 1)
.Count = 1
.ADDRowNum I
colP.Add CP, CStr(.Phrase)
Select Case Err.Number
Case 457 'duplicate
With colP(CStr(.Phrase))
.Count = .Count + 1
.ADDRowNum I
End With
Err.Clear
Case Is <> 0 'some other error. Stop to debug
Debug.Print "Error: " & Err.Number, Err.Description
Stop
End Select
End With
Next I
On Error GoTo 0
'Rows to be deleted
Set colRowNums = New Collection
For I = 1 To colP.Count
With colP(I)
Select Case .Count
Case 2
colRowNums.Add .RowNums(2)
Case Is > 2
For K = 1 To .RowNums.Count
colRowNums.Add .RowNums(K)
Next K
End Select
End With
Next I
'Revers Sort the collection of Row Numbers
'For speed, if necessary, could use
' faster sort routine
RevCollBubbleSort colRowNums
'Delete Rows
'For speed, could create Unions of up to 30 rows at a time
Application.ScreenUpdating = False
With wsSrc
For I = 1 To colRowNums.Count
.Rows(colRowNums(I)).Delete
Next I
End With
Application.ScreenUpdating = True
End Sub
'Could use faster sort routine if necessary
Sub RevCollBubbleSort(TempCol As Collection)
Dim I As Long
Dim NoExchanges As Boolean
' Loop until no more "exchanges" are made.
Do
NoExchanges = True
' Loop through each element in the array.
For I = 1 To TempCol.Count - 1
' If the element is less than the element
' following it, exchange the two elements.
If TempCol(I) < TempCol(I + 1) Then
NoExchanges = False
TempCol.Add TempCol(I), after:=I + 1
TempCol.Remove I
End If
Next I
Loop While Not (NoExchanges)
End Sub
no need to use that inefficient second loop in the second section, just use a live count like so
fin = ws.UsedRange.Rows.count
For i = 2 To fin
ws.Range("AZ" & i).value = Application.WorksheetFunction.CountIf(ws.Range("W2:W" & fin), ws.Range("W" & i))
Next i
For j = fin To 2 Step -1
If ws.Range("AZ" & j).value > 2 OR Application.WorksheetFunction.CountIf(ws.Range("W2:W" & fin), ws.Range("W" & j)) = 2 Then
ws.Range("AZ" & j).EntireRow.Delete
End If
Next j
While your logic is basically sound, the method is not the most efficient. The AutoFilter Method can quickly remove all counts greater than 2 and the Range.RemoveDuplicates¹ method cansubsequently make quick work of removing one of the rows that still contain duplicate values in column W.
Dim r As Long, c As Long
With ws
If .AutoFilterMode Then .AutoFilterMode = False
r = .Cells.SpecialCells(xlLastCell).Row
c = Application.Max(52, .Cells.SpecialCells(xlLastCell).Column)
With .Range("A1", .Cells(r, c)) '.UsedRange
With .Columns(52)
If IsEmpty(.Cells(1, 1)) Then .Cells(1, 1) = "count"
With .Resize(.Rows.Count - 1, 1).Offset(1, 0)
.Cells.FormulaR1C1 = "=COUNTIF(C[-29], RC[-29])"
.Cells = .Cells.Value
End With
.AutoFilter field:=1, Criteria1:=">2"
With .Resize(.Rows.Count - 1, 1).Offset(1, 0)
If CBool(Application.Subtotal(103, .Cells)) Then
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End If
End With
.AutoFilter
End With
.RemoveDuplicates Columns:=23, Header:=xlYes
End With
End With
When you rewrite the count values in column AZ, you are likely going to rewrite 3 counts to 2, etc.
¹ The Range.RemoveDuplicates method removes duplicate rows from the bottom up.

Resources