I am looking to speed up an on-worksheet open macro I have in excel.
Every time the worksheet is opened, I would like it to autofit x rows and then hide any rows that have a 0 in it.
The macro works fine, but I think there must be a better/faster way to hide all relevant rows. Any help would be appreciated.
Private Sub Worksheet_Activate()
Rows("14:859").EntireRow.AutoFit
Application.ScreenUpdating = False
Dim c As Range
For Each c In Range("O1:O859").Cells
If c.Value = "0" Then
c.EntireRow.Hidden = True
End If
Next c
Application.ScreenUpdating = True
End Sub
Try this version:
Option Explicit
Private Sub Worksheet_Activate()
Const LAST_ROW = 859
Const CL = 15 'O column
Const RO = 14
Const HIDE_ROWS = True 'or False
Dim ur As Variant, hr As Range, R As Long
Application.ScreenUpdating = False
Rows(RO & ":" & LAST_ROW).EntireRow.AutoFit
ur = Range(Cells(1, CL), Cells(LAST_ROW, CL))
For R = 1 To LAST_ROW
If Len(ur(R, 1)) = 0 Then Exit For
If ur(R, 1) = 0 Then
If hr Is Nothing Then Set hr = Cells(R, 1) Else: Set hr = Union(hr, Cells(R, 1))
End If
Next
hr.EntireRow.Hidden = HIDE_ROWS
Application.ScreenUpdating = True
End Sub
Related
I can not manage to cleanse my data of the "empty" rows. There is no problem in deleting the "0" but those cells which are empty are not empty but have something like "null strings" in it.
Sub Reinigung()
Application.ScreenUpdating = False
Application.EnableEvents = False
ListeEnde3 = ThisWorkbook.Sheets("input").Cells(Rows.Count, 1).End(xlUp).Row
For Zeile1 = 2 To ListeEnde3
If ThisWorkbook.Sheets("input").Cells(Zeile1, 14) = "0" Or ThisWorkbook.Sheets("2018").Cells(Zeile1, 14) = "" Then
ThisWorkbook.Sheets("input").Rows(Zeile1).Delete
Zeile1 = Zeile1 - 1
Else
End If
Next
' ThisWorkbook.Sheets("import").Columns(14).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
That code just freezes my excel, if i leave out the
thisWorkbook.Sheets("2018").Cells(Zeile1, 14) = ""
part, it works and deletes all rows, where colum 14 contains a "0".
If I check the cells which appear blank with =isblank it returns "false". There is no "space" in the cell and no " ' ".
What to do?
edit
After the first tips my code looks like this now:
Sub Reinigung()
Dim ListeEnde3 As Long
Dim Zeile1 As Long
Application.ScreenUpdating = False
Application.EnableEvents = False
ListeEnde3 = ThisWorkbook.Sheets("import").Cells(Rows.Count, 1).End(xlUp).Row
For Zeile1 = ListeEnde3 To 2 Step -1
Set rngX = ThisWorkbook.Sheets("import").Cells(Zeile1, 14)
If (rngX = "0" Or rngX = "") Then 'or rngY = vbNullString
ThisWorkbook.Sheets("import").Rows(Zeile1).Delete
End If
Next Zeile1
' ThisWorkbook.Sheets("import").Columns(14).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Excel still crashes / freezes (I waited for 5 minutes) but since the code runs "smoothly" with F8 I wanted to give it a shot with less data: It works!
If I am not reducing the data there are ~ 70000 rows to check. I let it run on 720 rows and it worked.
Any way to tweak the code in a way that it can handle the 70000+ rows? I didn't think that it would be too much.
Thanks!
You can use AutoFilter and delete the visible rows (not tested) :
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("import")
ws.UsedRange.AutoFilter 14, Array("=0", "="), xlFilterValues
ws.UsedRange.Offset(1).EntireRow.Delete
ws.AutoFilterMode = False
Another way is to simply use internal arrays and write out the new data set which has valid rows.
It is very fast.
If your dataset has formulas then you'll have to use extra code, but if it's constants only, then the below should do:
Sub Reinigung()
'Here I test with column E to Z, set Ranges appropriately
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim ListeEnde3 As Long, x As Long, y As Long
'last row of data - set to column of non-blank data
ListeEnde3 = ThisWorkbook.Sheets("import").Cells(Rows.Count, 5).End(xlUp).Row
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("import")
Dim startCell As Range
'set to whatever cell is the upper left corner of data
Set startCell = ThisWorkbook.Sheets("import").Range("E1")
Dim arr As Variant, arrToPrint() As Variant
'Get rightmost column of data instead of hardcoding to "Z"
'write dataset into an array
arr = ws.Range(startCell, ws.Range("Z" & ListeEnde3)).Value
x = UBound(arr) - LBound(arr) + 1 'num of rows of data
y = UBound(arr, 2) - LBound(arr, 2) + 1 'num of columns of data
ReDim arrToPrint(1 To x, 1 To y) 'array to hold valid/undeleted data
Dim i As Long, j As Long, printCounter As Long, arrayColumnToCheck as Long
arrayColumnToCheck = 14 - startCell.Column + 1 '14 is column N
For i = 1 To x
If arr(i, arrayColumnToCheck ) <> 0 And arr(i, arrayColumnToCheck ) <> vbNullString Then
printCounter = printCounter + 1
For j = 1 To y
'put rows to keep in arrToPrint
arrToPrint(printCounter, j) = arr(i, j)
Next j
End If
Next i
'Print valid rows to keep - only values will print - no formulas
startCell.Resize(printCounter, y).Value = arrToPrint
'Delete the rows with zero & empty cells off the sheet
startCell.Offset(printCounter).Resize(ListeEnde3 - printCounter, y).Delete xlShiftUp
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
You can add IsEmpty to your code to check the cells filling
Sub Reinigung()
Application.ScreenUpdating = False
Application.EnableEvents = False
ListeEnde3 = ThisWorkbook.Sheets("input").Cells(Rows.Count, 1).End(xlUp).Row
For Zeile1 = 2 To ListeEnde3
Set rngX = ThisWorkbook.Sheets("input").Cells(Zeile1, 14)
Set rngY = ThisWorkbook.Sheets("2018").Cells(Zeile1, 14)
If (rngX = "0" And (Not IsEmpty(rngX))) Or (rngY = "") Then
ThisWorkbook.Sheets("input").Rows(Zeile1).Delete
Zeile1 = Zeile1 - 1
End If
Next
' ThisWorkbook.Sheets("import").Columns(14).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
NEVER a good idea to alter a loop counter: Zeile1 = Zeile1 - 1
Instead start at the end and use Step -1 in your loop to work backward.
You are in a infinite loop because the loop doesnt move forward. If Zeile=3 and there is a "" in row3 in the '2018' sheet, then it will always be stuck on the Zeile1 = 3 line. You will always be coming back to that "" on row 3 in '2018'sheet.
For Zeile1 = ListeEnde3 To 2 Step -1
Set rngX = ThisWorkbook.Sheets("input").Cells(Zeile1, 14)
Set rngY = ThisWorkbook.Sheets("2018").Cells(Zeile1, 14)
If (rngX = "0" Or rngY = "") Then 'or rngY = vbNullString
ThisWorkbook.Sheets("input").Rows(Zeile1).Delete
End If
Next Zeile1
Is there a faster, or more practical way of hiding rows in all sheets that have a zero value in column A? I have set up multiple macros to hide the rows, but this takes about 50-70 secs to complete any faster way?
Sub Macro14()
Dim c As Range
For Each c In Sheets("Main").Range("A200:A500")
If c.value = 0 Then
Sheets("Main").Rows(c.Row).Hidden = True
Else
Sheets("Main").Rows(c.Row).Hidden = False
End If
Next
End Sub
Sub Macro15()
Dim c As Range
For Each c In Sheets("Elkhart East").Range("A50:A300")
If c.value = 0 Then
Sheets("Elkhart East").Rows(c.Row).Hidden = True
Else
Sheets("Elkhart East").Rows(c.Row).Hidden = False
End If
Next
End Sub
Sub Macro16()
Dim c As Range
For Each c In Sheets("Tennessee").Range("A50:A300")
If c.value = 0 Then
Sheets("Tennessee").Rows(c.Row).Hidden = True
Else
Sheets("Tennessee").Rows(c.Row).Hidden = False
End If
Next
End Sub
Sub Macro17()
Dim c As Range
For Each c In Sheets("Alabama").Range("A50:A300")
If c.value = 0 Then
Sheets("Alabama").Rows(c.Row).Hidden = True
Else
Sheets("Alabama").Rows(c.Row).Hidden = False
End If
Next
End Sub
Sub Macro18()
Dim c As Range
For Each c In Sheets("North Carolina").Range("A50:A300")
If c.value = 0 Then
Sheets("North Carolina").Rows(c.Row).Hidden = True
Else
Sheets("North Carolina").Rows(c.Row).Hidden = False
End If
Next
End Sub
Sub Macro19()
Dim c As Range
For Each c In Sheets("Pennsylvania").Range("A50:A300")
If c.value = 0 Then
Sheets("Pennsylvania").Rows(c.Row).Hidden = True
Else
Sheets("Pennsylvania").Rows(c.Row).Hidden = False
End If
Next
End Sub
Sub Macro20()
Dim c As Range
For Each c In Sheets("Texas").Range("A50:A300")
If c.value = 0 Then
Sheets("Texas").Rows(c.Row).Hidden = True
Else
Sheets("Texas").Rows(c.Row).Hidden = False
End If
Next
End Sub
Sub Macro21()
Dim c As Range
For Each c In Sheets("West Coast").Range("A50:A300")
If c.value = 0 Then
Sheets("West Coast").Rows(c.Row).Hidden = True
Else
Sheets("West Coast").Rows(c.Row).Hidden = False
End If
Next
End Sub
This should do it in a pretty fast way:
Sub test()
Dim x As Variant, i As Long, j(1) As Long, rngVal As Variant, rnghide As Range, rngshow As Range, sht As Object
For Each sht In ActiveWorkbook.Sheets(Array("Main", "Elkhart East", "Tennessee", "Alabama", "North Carolina", "Pennsylvania", "Texas", "West Coast"))
Set rnghide = Nothing
Set rngshow = Nothing
If sht.Name = "Main" Then
j(0) = 200
j(1) = 500
Else
j(0) = 50
j(1) = 300
End If
x = sht.Range("A1:A" & j(1)).Value
For i = j(0) To j(1)
If x(i, 1) = 0 Then
If rnghide Is Nothing Then Set rnghide = sht.Rows(i) Else Set rnghide = Union(rnghide, sht.Rows(i))
Else
If rngshow Is Nothing Then Set rngshow = sht.Rows(i) Else Set rngshow = Union(rngshow, sht.Rows(i))
End If
Next
rnghide.EntireRow.Hidden = True
rngshow.EntireRow.Hidden = False
Next
End Sub
It simply runs each sheet for the whole range and stores the rows to show/hide in seperate ranges and then change there status in one step (1 for show and 1 for hide for each sheet)
If you have any questions or get any errors just tell me (can't test it right now)
Use an array:
Sub t()
Dim sheetArray() As Variant
Dim ws&, finalRow&, startRow&
Dim c As Range
sheetArray = Array("Alabama", "North Carolina", "West Coast")
For ws = LBound(sheetArray) To UBound(sheetArray)
If sheetArray(ws) = "Main" Then
startRow = 200
finalRow = 500
Else
startRow = 50
finalRow = 300
End If
For Each c In Sheets(sheetArray(ws)).Range("A" & startRow & ":A" & finalRow)
If c.Value = 0 And Not IsEmpty(c) Then
Sheets(sheetArray(ws)).Rows(c.Row).Hidden = True
Else
Sheets(sheetArray(ws)).Rows(c.Row).Hidden = False
End If
Next c
Next ws
End Sub
Just add to that array and it should work a little faster for you. If you have a ton of sheets, and don't want to manually type them into the VBA code, you can always set the array to the range of sheet names, then just go from there. Let me know if you need help doing so.
This also assumes you don't want to just loop through the workbook. If so, you can just do For each ws in ActiveWorkbook instead of lBound()...
Edit: I added some code to check the sheet, so it'll correctly adjust your ranges.
use this :
For Each ws In ActiveWorkbook.Worksheets
For Each c In ws.Range(IIf(ws.Name = "Main", "A200:A500", "A50:A300"))
ws.Rows(c.Row).Hidden = c.Value = 0
Next
Next
if you want exclude sheet Raw,Main and Calendar :
Dim untreatedSheet As Variant
untreatedSheet = Array("Raw", "Main", "Calendar")
For Each ws In ActiveWorkbook.Worksheets
If Not (UBound(Filter(untreatedSheet, ws.Name)) > -1) Then
For Each c In ws.Range("A50:A300")
ws.Rows(c.Row).Hidden = c.Value = 0
Next
End If
Next
This will work if you select all the sheets you want filtered FIRST:
Sub HideRows()
Dim ws As Worksheet
sAddress = "A:A"
For Each ws In ActiveWindow.SelectedSheets
ws.Range(sAddress).AutoFilter Field:=1, Criteria1:="<>0"
Next ws
End Sub
I apologize if already exist a similar question, but if yes, I not found.
I'm new to programming in VBA and still do not know much of it, now I'm trying to run a function that will verify if in a column "B" are repeated velores and if exist will check in a column "C" where the highest value, copying the lowest to another table and deleting it.
The code already does all this however need to run in tables of 65 000 lines and it takes a long time, never got for running these tables, because even when I run in tables with 5000 or 10000 lines takes approximately 6 to 15 minutes.
My question is if there is any way to optimize the cycle that I'm using, it will be better to use a For Each or maintain the Do While Loop?
Here is the code I am using:
Function Copy()
Worksheets("Sheet1").Range("A1:AQ1").Copy _
Destination:=Worksheets("Sheet2").Range("A1")
Dim lRow As Long
Dim lRow2 As Long
Dim Row As Long
Dim countA As Long
Dim countB As Long
Dim t As Double
lRow = 5000
Row = 2
countA = 0
countB = 0
Application.ScreenUpdating = False
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
Application.EnableEvents = False
Application.DisplayStatusBar = False
ActiveSheet.DisplayPageBreaks = False
lRow2 = lRow - 1
t = Timer
Do While lRow > 2
If (Cells.Item(lRow, "B") <> Cells.Item(lRow2, "B")) Then
lRow = lRow - 1
lRow2 = lRow - 1
Else
If (Cells.Item(lRow, "C") > Cells.Item(lRow2, "C")) Then
Sheets("Sheet1").Rows(lRow2).Copy Sheets("Sheet2").Rows(Row)
Rows(lRow2).Delete
lRow = lRow - 1
Row = Row + 1
countA = countA + 1
Else
Sheets("Sheet1").Rows(lRow).Copy Sheets("Sheet2").Rows(Row)
Rows(lRow).Delete
lRow = lRow - 1
Row = Row + 1
countB = countB + 1
End If
lRow2 = lRow2 - 1
End If
Loop
Application.DisplayStatusBar = True
ActiveWindow.View = ViewMode
Application.ScreenUpdating = False
MsgBox "A = " & countA & " B = " & countB & "Time (minutes): " & (Timer - t) / 60
End Function
As long as you've entered the VBA environment for a solution, there seems little point in not continuing that avenue toward the best route possible. The following uses a pair of Scripting.Dictionaries to build two sets of data from the original matrix in Sheet1. In addition to the main sub procedure, there are two short 'helper' functions that breach the 65536 barrier that Application.Index and Application.Transpose suffer from. These are necessary to peel out a row from a large two-dimensioned array and flip the orientation of the results while simultaneously splitting the stored records.
Sub Keep_Highest_BC()
Dim d As Long, dHIGHs As Object, dDUPEs As Object
Dim v As Long, vTMPs() As Variant, iCOLs As Long
Debug.Print Timer
'On Error GoTo bm_Safe_Exit
Set dHIGHs = CreateObject("Scripting.Dictionary")
Set dDUPEs = CreateObject("Scripting.Dictionary")
With Worksheets("Sheet1")
iCOLs = .Columns("AQ").Column
.Cells(1, 1).Resize(2, iCOLs).Copy _
Destination:=Worksheets("Sheet2").Cells(1, 1)
With .Cells(2, 1).Resize(.Cells(Rows.Count, 2).End(xlUp).Row - 1, iCOLs)
vTMPs = .Value2
End With
End With
For v = LBound(vTMPs, 1) To UBound(vTMPs, 1)
If dHIGHs.exists(vTMPs(v, 2)) Then
If CDbl(Split(dHIGHs.Item(vTMPs(v, 2)), ChrW(8203))(2)) < vTMPs(v, 3) Then
dDUPEs.Add Key:=vTMPs(v, 2) & v, Item:=dHIGHs.Item(vTMPs(v, 2))
dHIGHs.Item(vTMPs(v, 2)) = joinAtoAQ(vTMPs, v)
Else
dDUPEs.Add Key:=vTMPs(v, 2) & v, Item:=joinAtoAQ(vTMPs, v)
End If
Else
dHIGHs.Add Key:=vTMPs(v, 2), Item:=joinAtoAQ(vTMPs, v)
End If
Next v
With Worksheets("Sheet1")
With .Cells(2, 1).Resize(.Cells(Rows.Count, 2).End(xlUp).Row - 1, iCOLs)
.ClearContents
With .Resize(dHIGHs.Count, iCOLs)
.Value = transposeSplitLargeItemArray(dHIGHs.items)
End With
End With
End With
With Worksheets("Sheet2")
With .Cells(1, 1).CurrentRegion.Offset(1, 0)
.ClearContents
With .Resize(dDUPEs.Count, iCOLs)
.Value = transposeSplitLargeItemArray(dDUPEs.items)
.Rows(1).Copy
.PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End With
End With
End With
bm_Safe_Exit:
dHIGHs.RemoveAll: Set dHIGHs = Nothing
dDUPEs.RemoveAll: Set dDUPEs = Nothing
Debug.Print Timer
End Sub
Function joinAtoAQ(vTMP As Variant, ndx As Long)
Dim sTMP As String, v As Long
For v = LBound(vTMP, 2) To UBound(vTMP, 2)
sTMP = sTMP & vTMP(ndx, v) & ChrW(8203)
Next v
joinAtoAQ = Left$(sTMP, Len(sTMP) - 1)
End Function
Function transposeSplitLargeItemArray(vITMs As Variant)
Dim v As Long, w As Long, vTMPs As Variant, vITM As Variant
ReDim vTMPs(LBound(vITMs) To UBound(vITMs), LBound(vITMs) To UBound(Split(vITMs(LBound(vITMs)), ChrW(8203))))
For v = LBound(vITMs) To UBound(vITMs)
vITM = Split(vITMs(v), ChrW(8203))
For w = LBound(vITM) To UBound(vITM)
vTMPs(v, w) = vITM(w)
Next w
Next v
transposeSplitLargeItemArray = vTMPs
End Function
Once the two dictionaries have been filled with maximum values and duplicate lesser values, the arrays are returned to the two worksheets en masse and subsequently split back into the 43 columns. One final effort is made to restore the original formatting from Sheet1 into Sheet2's data area.
I tested this on 75,000 rows of columns A through column AQ containing random sample data first with predominantly duplicate values in column B and then with roughly half duplicate values in column B. The first single pass was processed in 13.19 seconds; the second in 14.22. While your own results will depend on the machine you are running it on, I would expect a significant improvement over your original code. Post your own timed results (start and stop in seconds within the VBE's Immediate window, Ctrl+G) into the comments if you can.
Everything i could think of has already been mentioned above, however this code snippet might help someone out, it's the least you could do to make a macro faster (in case no interaction is required during runtime of the macro)
Run Optimize(True) at the start of your code, Optimize(False) at the end.
'Toggles unnecessary excel features
Sub Optimize(start As Boolean)
On Error Resume Next
With Application
.ScreenUpdating = Not (start)
.DisplayStatusBar = Not (start)
.EnableEvents = Not (start)
If start Then
.Calculation = xlCalculationManual
Else
.Calculation = xlCalculationAutomatic
End If
End With
On Error GoTo 0
End Sub
Typically it's faster to perform a single delete at the end of the loop.
Untested:
Function Copy()
Dim shtSrc As Worksheet, shtDest As Worksheet
Dim lRow As Long, Row As Long, viewmode
Dim countA As Long, countB As Long
Dim t As Double, rw As Range, rngDel As Range
lRow = 5000
Row = 2
countA = 0
countB = 0
Set shtSrc = Worksheets("Sheet1")
Set shtDest = Worksheets("Sheet2")
shtSrc.Range("A1:AQ1").Copy Destination:=shtDest.Range("A1")
Application.ScreenUpdating = False
viewmode = ActiveWindow.View
ActiveWindow.View = xlNormalView
Application.EnableEvents = False
Application.DisplayStatusBar = False
ActiveSheet.DisplayPageBreaks = False
t = Timer
Do While lRow > 2
Set rw = shtSrc.Rows(lRow)
If (rw.Cells(2) = rw.Cells(2).Offset(-1, 0)) Then
If (rw.Cells(3) > rw.Cells(3).Offset(-1, 0)) Then
rw.Offset(-1, 0).Copy shtDest.Rows(Row)
AddToRange rngDel, rw.Offset(-1, 0)
countA = countA + 1
Else
rw.Copy shtDest.Rows(Row)
AddToRange rngDel, rw
countB = countB + 1
End If
Row = Row + 1
End If
lRow = lRow - 1
Loop
'anything to delete?
If Not rngDel Is Nothing Then
rngDel.Delete
End If
Application.DisplayStatusBar = True
ActiveWindow.View = viewmode
Application.ScreenUpdating = False
MsgBox "A = " & countA & " B = " & countB & "Time (minutes): " & (Timer - t) / 60
End Function
'utility sub for building up a range
Sub AddToRange(rngTot, rng)
If rngTot Is Nothing Then
Set rngTot = rng
Else
Set rngTot = Application.Union(rng, rngTot)
End If
End Sub
I have the following basic script that merges cells with the same value in Column R
Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rngMerge As Range, cell As Range
Set rngMerge = Range("R1:R1000")
MergeAgain:
For Each cell In rngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
What I would like to do is repeat this in columns A:Q and S:T but, I would like these columns to be merged in the same merged cell ranges as column R, i.e. if R2:R23 is merged then A2:A23, B2:B23, C2:C23 etc. will also be merge.
Columns A:Q do not contain values, column S:T have values but, these will be the same values throughout the range.
Any ideas
Apols for the earlier edit - this now deals with more than one duplicate in col R.
Note that this approach will work on the current (active) sheet.
Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim cval As Variant
Dim currcell As Range
Dim mergeRowStart As Long, mergeRowEnd As Long, mergeCol As Long
mergeRowStart = 1
mergeRowEnd = 1000
mergeCol = 18 'Col R
For c = mergeRowStart To mergeRowEnd
Set currcell = Cells(c, mergeCol)
If currcell.Value = currcell.Offset(1, 0).Value And IsEmpty(currcell) = False Then
cval = currcell.Value
strow = currcell.Row
endrow = strow + 1
Do While cval = currcell.Offset(endrow - strow, 0).Value And Not IsEmpty(currcell)
endrow = endrow + 1
c = c + 1
Loop
If endrow > strow+1 Then
Call mergeOtherCells(strow, endrow)
End If
End If
Next c
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub mergeOtherCells(strw, enrw)
'Cols A to T
For col = 1 To 20
Range(Cells(strw, col), Cells(enrw, col)).Merge
Next col
End Sub
You can try the below code as well. It would require you to put a 'No' after the last line in column R (R1001) so as to end the while loop.
Sub Macro1()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
flag = False
k = 1
While ActiveSheet.Cells(k, 18).Value <> "No"
i = 1
j = 0
While i < 1000
rowid = k
If Cells(rowid, 18).Value = Cells(rowid + i, 18).Value Then
j = j + 1
flag = True
Else
i = 1000
End If
i = i + 1
Wend
If flag = True Then
x = 1
While x < 21
Range(Cells(rowid, x), Cells(rowid + j, x)).Merge
x = x + 1
Wend
flag = False
k = k + j
End If
k = k + 1
Wend
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I have a big Excel sheet containing +100k rows and have an autofilter on one column of text values with category numbers and descriptions. There are thousands of different values in column F, so updating the autofilter is very impractical via using the standard UI.
How can I create a macro that removes the currently active cell's value from the autofilter that is active on the same column?
With the help of an expert, we came to a working solution for my case.
Just posting this as solution for others:
Sub Clear_Filter_and_Value()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim w As Worksheet
Dim filterArray()
Dim currentFiltRange As String
Dim col As Integer
Dim flag As Boolean
Set w = ActiveSheet
If w.AutoFilterMode = False Then Selection.AutoFilter
flag = False
On Error GoTo exit1
With w.AutoFilter
currentFiltRange = .Range.Address
With .Filters
For f = 1 To .Count
With .Item(f)
If .On Then
If ActiveCell.Column = f Then
ReDim filterArray(1 To .Count)
If .Count = 2 Then
filterArray(1) = .Criteria1
filterArray(2) = .Criteria2
Else
filterArray(1) = .Criteria1
End If
End If
ElseIf ActiveCell.Column = f Then
tR = Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row
ReDim filterArray(1 To tR - 1)
For i = 2 To tR
filterArray(i - 1) = Cells(i, ActiveCell.Column).Value
flag = True
Next i
End If
End With
Next f
End With
End With
w.AutoFilterMode = False
j = 1
ReDim newArray(1 To UBound(filterArray))
If flag = False Then
On Error GoTo 1
For i = 1 To UBound(filterArray(1))
On Error GoTo 1
If InStr(1, filterArray(1)(i), ActiveCell.Value) = 0 Then
newArray(j) = filterArray(1)(i)
j = j + 1
End If
Next i
Else
1:
Err.Clear
For i = 1 To UBound(filterArray)
If InStr(1, filterArray(i), ActiveCell.Value) = 0 Then
newArray(j) = filterArray(i)
j = j + 1
End If
Next i
End If
For col = 1 To 1
If Not IsEmpty(filterArray(1)) Then
w.Range(currentFiltRange).AutoFilter Field:=ActiveCell.Column, Criteria1:=newArray, Operator:=xlFilterValues
End If
Next col
exit1:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub