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
Related
I have in column A multiple strings of numbers that look like:
2222222266622222266666222222222222266622666666222
2222266666622222222666662222666222222666222222222
2222266622226666662266622266622222222222222222666
2222222222222666222226662266622226666622222222666
2666662266622222222222222222222666222222666222666
2222266622222666666666662266622222222222222222222
6662266622226662222266622222666222222266622222222
2666622666666222666222222666222222222222222222222
2222266626662666222222266622222222222666222266622
and so on.
I'm trying to find the values that are 90% the same or another percentage that I would choose before I run the program.
The expected result should be in column B how many other cells would share the same structure as much as an percentage with column A, and if it is possible in next column or columns, the cells that gave that similitude
My first try:
Sub Similar()
Dim stNow As Date
Dim DATAsheet As Worksheet
Dim firstrow As Integer
Dim finalrow As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim String_i, Len_i, String_j, Len_j
stNow = Now
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set DATAsheet = Sheet1
DATAsheet.Select
firstrow = Cells(1, 2).End(xlDown).Row
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
For i = firstrow To finalrow
For j = firstrow To finalrow
If i > 3 And j > 3 And i <> j Then
String_i = Cells(i, 1).Value
Len_i = Len(String_i)
String_j = Cells(j, 1).Value
Len_j = Len(String_j)
For k = 1 To Len_i
For l = 1 To Len_j
If Mid(String_i, k, 1) = Mid(String_j, l, 1) Then
Cells(j, 2).Value = Cells(j, 2).Value + 1
End If
Next l
Next k
End If
DoEvents
Next j
Application.StatusBar = "Loop 1/1 --- Done: " & Round((i / finalrow * 100), 0) & " %"
Next i
Application.StatusBar = ""
MsgBox "Done"
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
But it gaves me in column B the results:
259461.00
262794.00
262794.00
262794.00
259461.00
266123.00
259461.00
259461.00
Any help is appreciated.
Thanks!!!
VladMale first we will need lengt of this string - function LEN, and then we will need comparing substrings - function MID. Second function should be made in some loop from first to last character in a string, and every time it will match, some other cell should count how many times it mached and how many not. The posivite result we can divide by the string length * 100 and compare if it is more or less than 90%
I am writing a VBA code on excel using loops to go through 10000+ lines.
Here is an example of the table
And here is the code I wrote :
Sub Find_Matches()
Dim wb As Workbook
Dim xrow As Long
Set wb = ActiveWorkbook
wb.Worksheets("Data").Activate
tCnt = Sheets("Data").UsedRange.Rows.Count
Dim e, f, a, j, h As Range
xrow = 2
Application.ScreenUpdating = False
Application.Calculation = xlManual
For xrow = 2 To tCnt Step 1
Set e = Range("E" & xrow)
Set f = e.Offset(0, 1)
Set a = e.Offset(0, -4)
Set j = e.Offset(0, 5)
Set h = e.Offset(0, 3)
For Each Cell In Range("E2:E" & tCnt)
If Cell.Value = e.Value Then
If Cell.Offset(0, 1).Value = f.Value Then
If Cell.Offset(0, -4).Value = a.Value Then
If Cell.Offset(0, 5).Value = j.Value Then
If Cell.Offset(0, 3).Value = h.Value Then
If (e.Offset(0, 7).Value) + (Cell.Offset(0, 7).Value) = 0 Then
Cell.EntireRow.Interior.Color = vbYellow
e.EntireRow.Interior.Color = vbYellow
End If
End If
End If
End If
End If
End If
Next
Next
End Sub
As you can imagine, this is taking a lot of time to go through 10000+ lines and I would like to find a faster solution. There must be a method I don't think to avoid the over looping
Here are the condition :
For each line, if another line anywhere in the file has the exact same
:
Buyer ID (col. E)
`# purchased (col. F)
Product ID (col.A)
Payment (col. J)
Date purchased (col. H)
Then, if the SUM of the Amount (col. L) the those two matching line is
0, then color both rows in yellow.
Note that extra columns are present and not being compared (eg- col. B) but are still important for the document and cannot be deleted to ease the process.
Running the previous code, in my example, row 2 & 5 get highlighted :
This is using nested dictionaries and arrays to check all conditions
Timer with my test data: Rows: 100,001; Dupes: 70,000 - Time: 14.217 sec
Option Explicit
Public Sub FindMatches()
Const E = 5, F = 6, A = 1, J = 10, H = 8, L = 12
Dim ur As Range, x As Variant, ub As Long, d As Object, found As Object
Set ur = ThisWorkbook.Worksheets("Data").UsedRange
x = ur
Set d = CreateObject("Scripting.Dictionary")
Set found = CreateObject("Scripting.Dictionary")
Dim r As Long, rId As String, itm As Variant, dupeRows As Object
For r = ur.Row To ur.Rows.Count
rId = x(r, E) & x(r, F) & x(r, A) & x(r, J) & x(r, H)
If Not d.Exists(rId) Then
Set dupeRows = CreateObject("Scripting.Dictionary")
dupeRows(r) = 0
Set d(rId) = dupeRows
Else
For Each itm In d(rId)
If x(r, L) + x(itm, L) = 0 Then
found(r) = 0
found(itm) = 0
End If
Next
End If
Next
Application.ScreenUpdating = False
For Each itm In found
ur.Range("A" & itm).EntireRow.Interior.Color = vbYellow
Next
Application.ScreenUpdating = True
End Sub
Before
After
I suggest a different approach altogether: add a temporary column to your data that contains a concatenation of each cell in the row. This way, you have:
A|B|C|D|E
1|Mr. Smith|500|A|1Mr. Smith500A
Then use Excel's conditional formatting on the temporary column, highlighting duplicate values. There you have your duplicated rows. Now it's only a matter of using a filter to check which ones have amounts equal to zero.
You can use the CONCATENATE function; it requires you to specify each cell separately and you can't use a range, but in your case (comparing only some of the columns) it seems like a good fit.
Maciej's answer is easy to implement (if you can add columns to your data without interrupting anything), and I would recommend it if possible.
However, for the sake of answering your question, I will contribute a VBA solution as well. I tested it on dataset that is a bit smaller than yours, but I think it will work for you. Note that you might have to tweak it a little (which row you start on, table name, etc) to fit your workbook.
Most notably, the segment commented with "Helper column" is something you most likely will have to adjust - currently, it compares every cell between A and H for the current row, which is something you may or may not want.
I've tried to include a little commentary in the code, but it's not much. The primary change is that I'm using in-memory processing of an array rather than iterating over a worksheet range (which for larger datasets should be exponentially faster).
Option Base 1
Option Explicit
' Uses ref Microsoft Scripting Runtime
Sub Find_Matches()
Dim wb As Workbook, ws As Worksheet
Dim xrow As Long, tCnt As Long
Dim e As Range, f As Range, a As Range, j As Range, h As Range
Dim sheetArr() As Variant, arr() As Variant
Dim colorTheseYellow As New Dictionary, colorResults() As String, dictItem As Variant
Dim arrSize As Long, i As Long, k As Long
Dim c As Variant
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Data")
ws.Activate
tCnt = ws.UsedRange.Rows.Count
xrow = 2
Application.ScreenUpdating = False
Application.Calculation = xlManual
' Read range into an array so we process in-memory
sheetArr = ws.Range("A2:H" & tCnt)
arrSize = UBound(sheetArr, 1)
' Build new arr with "helper column"
ReDim arr(1 To arrSize, 1 To 9)
For i = 1 To arrSize
For k = 1 To 8
arr(i, k) = sheetArr(i, k)
arr(i, 9) = CStr(arr(i, 9)) & CStr(arr(i, k)) ' "Helper column"
Next k
Next i
' Iterate over array & build collection to indicate yellow lines
For i = LBound(arr, 1) To UBound(arr, 1)
If Not colorTheseYellow.Exists(i) Then colorResults = Split(ReturnLines(arr(i, 9), arr), ";")
For Each c In colorResults
If Not colorTheseYellow.Exists(CLng(c)) Then colorTheseYellow.Add CLng(c), CLng(c)
Next c
Next i
' Enact row colors
For Each dictItem In colorTheseYellow
'Debug.Print "dict: "; dictItem
If dictItem <> 0 Then ws.ListObjects(1).ListRows(CLng(dictItem)).Range.Interior.Color = vbYellow
Next dictItem
End Sub
Function ReturnLines(ByVal s As String, ByRef arr() As Variant) As String
' Returns a "Index;Index" string indicating the index/indices where the second, third, etc. instance(s) of s was found
' Returns "0;0" if 1 or fewer matches
Dim i As Long
Dim j As Long
Dim tmp As String
ReturnLines = 0
j = 0
tmp = "0"
'Debug.Print "arg: " & s
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, 9) = s Then
j = j + 1
'Debug.Print "arr: " & arr(i, 9)
'Debug.Print "ReturnLine: " & i
tmp = tmp & ";" & CStr(i)
End If
Next i
'If Left(tmp, 1) = ";" Then tmp = Mid(tmp, 2, Len(tmp) - 1)
'Debug.Print "tmp: " & tmp
If j >= 2 Then
ReturnLines = tmp
Else
ReturnLines = "0;0"
End If
End Function
On my simple dataset, it yields this result (marked excellently with freehand-drawn color indicators):
Thanks everybody for your answers,
Paul Bica's solution actually worked and I am using a version of this code now.
But, just to animate the debate, I think I also found another way around my first code, inspired by Maciej's idea of concatenating the cells and using CStr to compare the values and, of course Vegard's in-memory processing by using arrays instead of going through the workbook :
Sub Find_MatchesStr()
Dim AmountArr(300) As Variant
Dim rowArr(300) As Variant
Dim ws As Worksheet
Dim wb As Workbook
Set ws = ThisWorkbook.Sheets("Data")
ws.Activate
Range("A1").Select
rCnt = ws.Cells.SpecialCells(xlCellTypeLastCell).Row
For i = 2 To rCnt
If i = rCnt Then
Exit For
Else
intCnt = 0
strA = ws.Cells(i, 1).Value
strE = ws.Cells(i, 5).Value
strF = ws.Cells(i, 6).Value
strH = ws.Cells(i, 8).Value
strL = ws.Cells(i, 10).Value
For j = i To rCnt - 1
strSearchA = ws.Cells(j, 1).Value
strSearchE = ws.Cells(j, 5).Value
strSearchF = ws.Cells(j, 6).Value
strSearchH = ws.Cells(j, 8).Value
strSearchL = ws.Cells(j, 10).Value
If CStr(strE) = CStr(strSearchE) And CStr(strA) = CStr(strSearchA) And CStr(strF) = CStr(strSearchF) And CStr(strH) = CStr(strSearchH) And CStr(strL) = CStr(strSearchL) Then
AmountArr(k) = ws.Cells(j, 12).Value
rowArr(k) = j
intCnt = intCnt + 1
k = k + 1
Else
Exit For
End If
Next
strSum = 0
For s = 0 To UBound(AmountArr)
If AmountArr(s) <> "" Then
strSum = strSum + AmountArr(s)
Else
Exit For
End If
Next
strAppenRow = ""
For b = 0 To UBound(rowArr)
If rowArr(b) <> "" Then
strAppenRow = strAppenRow & "" & rowArr(b) & "," & AmountArr(b) & ","
Else
Exit For
End If
Next
If intCnt = 1 Then
Else
If strSum = 0 Then
For rn = 0 To UBound(rowArr)
If rowArr(rn) <> "" Then
Let rRange = rowArr(rn) & ":" & rowArr(rn)
Rows(rRange).Select
Selection.Interior.Color = vbYellow
Else
Exit For
End If
Next
Else
strvar = ""
strvar = Split(strAppenRow, ",")
For ik = 1 To UBound(strvar)
If strvar(ik) <> "" Then
strVal = CDbl(strvar(ik))
For ik1 = ik To UBound(strvar)
If strvar(ik1) <> "" Then
strVal1 = CDbl(strvar(ik1))
If strVal1 + strVal = 0 Then
Let sRange1 = strvar(ik - 1) & ":" & strvar(ik - 1)
Rows(sRange1).Select
Selection.Interior.Color = vbYellow
Let sRange = strvar(ik1 - 1) & ":" & strvar(ik1 - 1)
Rows(sRange).Select
Selection.Interior.Color = vbYellow
End If
Else
Exit For
End If
ik1 = ik1 + 1
Next
Else
Exit For
End If
ik = ik + 1
Next
End If
End If
i = i + (intCnt - 1)
k = 0
Erase AmountArr
Erase rowArr
End If
Next
Range("A1").Select
End Sub
I still have some mistakes (rows not higlighted when they should be), the above code is not perfect, but I thought it'd be OK to give you an idea of where I was going before Paul Bica's solution came in.
Thanks again !
If your data is only till column L, then use below code, I found it is taking less time to run....
Sub Duplicates()
Application.ScreenUpdating = False
Dim i As Long, lrow As Long
lrow = Cells(Rows.Count, 1).End(xlUp).Row
Range("O2") = "=A2&E2&F2&J2&L2"
Range("P2") = "=COUNTIF(O:O,O2)"
Range("O2:P" & lrow).FillDown
Range("O2:O" & lrow).Copy
Range("O2:O" & lrow).PasteSpecial xlPasteValues
Application.CutCopyMode = False
For i = 1 To lrow
If Cells(i, 16) = 2 Then
Cells(i, 16).EntireRow.Interior.Color = vbYellow
End If
Next
Application.ScreenUpdating = True
Range("O:P").Delete
Range("A1").Select
MsgBox "Done"
End Sub
I've got a code that puts all the data of my Excel file (rows = 12,5k+ and columns = 97) in to a two-dimensional string. Then it loops through a certain column ("G") to list an listbox ("listbox1") with only unique findings.
Then in the Userform the user can choose to select some of the found items and transform it to another listbox ("Listbox2") Then when the user hits the button (CommandButton4) I would like the code to filter the array on only the rows where in column "G" it is the same as in one (or more) given criteria in listbox2.
It works when It has only one item in the listbox but when given two items in the listbox, it only returns everything blank.
Can some one please tell me what I'm doing wrong because I've no idea.
code:
Private Sub CommandButton4_Click()
Dim arr2() As Variant
Dim data As Variant
Dim B_List As Boolean
Dim i As Long, j As Long, q As Long, r As Long, LastColumn As Long, LastRow As Long
q = 1
r = 1
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("Sheet3")
Application.ScreenUpdating = False
Application.EnableEvents = False
With ThisWorkbook.Sheets("Sheet3")
LastRow = .Cells(Rows.Count, 2).End(xlUp).Row
LastColumn = .Cells(3, Columns.Count).End(xlToLeft).Column
ReDim arr2(1 To LastRow, 1 To LastColumn)
For i = 2 To LastRow
For j = 1 To LastColumn
arr2(i, j) = .Cells(i, j).Value
Next j
Next i
End With
For i = 1 To LastRow
For j = 0 To Me.ListBox2.ListCount - 1
If ListBox2.List(j) = arr2(i, 7) Then
'Later aan te passen
Else
For q = 1 To LastColumn
arr2(i, q) = ""
Next q
End If
Next j
Next i
Sheets("Sheet3").UsedRange.ClearContents
For i = LBound(arr2, 1) To UBound(arr2, 1)
If arr2(i, 2) <> "" Then
r = r + 1
For j = LBound(arr2, 2) To UBound(arr2, 2)
ThisWorkbook.Sheets("Sheet3").Cells(r, j).Value = arr2(i, j)
Next j
End If
Debug.Print i, j, arr2(i, 7)
Next i
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
The issue is your second nested-loop:
For i = 1 To LastRow
For j = 0 To Me.ListBox2.ListCount - 1
If ListBox2.List(j) = arr2(i, 7) Then
'Later aan te passen
Else
For q = 1 To LastColumn
arr2(i, q) = ""
Next q
End If
Next j
Next i
Suppose that our ListBox has 2 values, "First" and "Second". For each row, you do the following:
j = 0
ListBox2.List(0) = "First"
If Column G is "First", do nothing
Otherwise, make the whole Row Blank Including if Column G = "Second"
At this point, the only possible values for Column G are now "First" or Blank
j = 1
ListBox2.List(1) = "Second"
If Column G is "Second", do nothing But, this cannot happen, because you have already changed any "Second" Rows to Blank
Otherwise, make the whole Row Blank
At this point, the Row will always be Blank
I recommend having a Boolean test variable. Set it to False at the start of each Row-loop, and set it to True if you find a match. If it is still False after you check all ListBox items, then blank the row:
Dim bTest AS Boolean
For i = 1 To LastRow
bTest = False 'Reset for the Row
For j = 0 To Me.ListBox2.ListCount - 1
If ListBox2.List(j) = arr2(i, 7) Then
bTest = True 'We found a match!
Exit For 'No need to keep looking
End If
Next j
If Not bTest Then 'If we didn't find a match
For q = 1 To LastColumn
arr2(i, q) = "" 'Blank the row
Next q
End If
Next i
I have written the following code for one of my worksheets.
Sub Hide_Projects()
Application.ScreenUpdating = False
i = 6
For i = 6 To 350
Cells(9, i).Select
If Selection.Value = "Project" Then
ActiveCell.EntireColumn.Hidden = True
Else
ActiveCell.EntireColumn.Hidden = False
End If
Next i
Application.ScreenUpdating = True
End Sub
It works fine, does exactly what I need it to every time without crashing or lagging. However, when I use a similar code on a different worksheet, only this time applied to rows rather than columns, it either crashes my Excel or takes about 2 minutes to run, even though the code is identical. This is the second code:
Sub Hide_Projects_5yr()
Application.ScreenUpdating = False
i = 6
For i = 6 To 350
Cells(i, 7).Select
If Selection.Value = "Project" Then
ActiveCell.EntireRow.Hidden = True
Else
ActiveCell.EntireRow.Hidden = False
End If
Next i
Application.ScreenUpdating = True
End Sub
Does anyone have any idea why this is the case?
Thank you!
Obviously columns are times faster to hide than rows. I have tried this:
Option Explicit
Public Sub TestingSpeed()
Dim lngCount As Long
Dim dtTime As Date
Columns.Hidden = False
rows.Hidden = False
dtTime = Now
For lngCount = 1 To 300
rows(lngCount).Hidden = True
Next lngCount
Debug.Print "Rows: -> "; DateDiff("s", dtTime, Now())
dtTime = Now
For lngCount = 1 To 300
Columns(lngCount).Hidden = True
Next lngCount
Debug.Print "Cols: -> "; DateDiff("s", dtTime, Now())
End Sub
The result is the following (in seconds):
Rows: -> 9
Cols: -> 2
And the difference grows somehow exponentially.
With 1.000 samples it is like this:
Rows: -> 11
Cols: -> 1
With 10.000 like this:
Rows: -> 19
Cols: -> 10
It is very likely that your active sheet is not the one you intend to work on. It is always best to avoid Select and ActiveCell, because you are dependent on the cursor location. Not sure you need the false case, unless you use the same sheet over and over again and it may be hidden.
Sub Hide_Projects_5yr()
Application.ScreenUpdating = False
Dim ws as Worksheet
Set ws = Sheets("YourSheetName")
For i = 6 To 350
If ws.Cells(i, 7).Value = "Project" Then
ws.Cells(i, 7).EntireRow.Hidden = True
Else
ws.Cells(i, 7).EntireRow.Hidden = False
End If
Next i
Application.ScreenUpdating = True
End Sub
Could you try giving your code full addresses to your cells? Besides, it is a good idea not using the select command. Here's my modifications to your code:
Sub Hide_Projects()
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("Put the name of your sheet here")
For i = 6 To 350
If .Cells(9, i).Text = "Project" Then
.Columns(i).Hidden = True
Else
.Columns(i).Hidden = False
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Your second code would look like this:
Sub Hide_Projects_5yr()
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("Put the name of your second sheet here")
For i = 6 To 350
If .Cells(i, 7).Text = "Project" Then
.Rows(i).Hidden = True
Else
.Rows(i).Hidden = False
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Let me know if the error message keeps appearing.
Your main slowdown is a result of reading data from the worksheet too many times. Load the cell values into an array first, then loop through that.
You can also gain a bit of speed by unhiding the rows all at once at the outset, then hiding if the "="Project" condition is true. Again, this reduces the number of calls to the worksheet; your current version sets the ".Hidden" property of each row one-by-one.
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim tempArr As Variant
tempArr = Range(Cells(6, 7), Cells(350, 7)).Value
Rows("6:350").Hidden = False
j = 1
For i = LBound(tempArr, 1) To UBound(tempArr, 1)
If tempArr(i, 1) = "Project" Then
Rows(j + 5).Hidden = True
End If
j = j + 1
Next
Application.ScreenUpdating = True
If you're really concerned about speed, you could also reduce the number of trips to the worksheet by checking for consecutive rows containing "Project". This version runs ~2x as fast as the other one (tested on a sample of 200k rows). It makes the code a lot more complex, though.
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim k As Long
Dim tempArr As Variant
Dim consBool As Boolean
tempArr = Range(Cells(6, 7), Cells(350, 7)).Value
Rows("6:350").Hidden = False
j = 1
For i = LBound(tempArr, 1) To UBound(tempArr, 1)
consBool = True
If tempArr(i, 1) = "Project" Then
k = i
Do Until consBool = False
If k = UBound(tempArr, 1) Then
consBool = False
ElseIf tempArr(k + 1, 1) = "Project" Then
k = k + 1
Else
consBool = False
End If
Loop
Rows(j + 5 & ":" & k + 5).Hidden = True
j = j + 1 + (k - i)
i = k
Else
j = j + 1
End If
Next
Application.ScreenUpdating = True
Here's what it'd look like if I were going to implement this in a larger project. Among other optimizations, I've added some features (it can check for partial matches, check multiple columns for your criteria, and do an "inverted" mode that hides all rows not containing your criteria) and made sure that you're required to specify your worksheet.
Option Explicit
Sub exampleMacro()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Call hideRows(ThisWorkbook.Sheets("Example WS"), 6, 350, "Project", 7, 7)
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub hideRows(ws As Worksheet, startRow As Long, endRow As Long, valCrit As String, Optional startCol As Long = 1, Optional endCol As Long = 1, Optional invert As Boolean = False, Optional checkAll As Boolean = False)
'Hides rows in a range (startRow to endRow) in a worksheet (ws)
'Hides when row contains a value (valCrit; partial strings are accepted) in a column or series of columns (startCol to endCol)
'In inverted mode (invert), hides rows that do *not* contain value
'If (checkAll) is True, all columns must contain value to be hidden/unhidden
'Usage examples:
'Call hideRows(exampleWS, 1, 1000, "Foo", 1, 10) -> hides rows that contain a cell in columns 1-10 with exact value "Foo"
'Call hideRows(exampleWS, 1, 1000, "*Foo*", 1, 10) -> hides rows that contain a cell in columns 1-10 that contains partial string "*Foo*"
'Call hideRows(exampleWS, 1, 1000, "Foo", 1, 10, True) -> hides rows that contain no cells in columns 1-10 with exact value "Foo"
'Call hideRows(exampleWS, 1, 1000, "Foo", 1, 10, False, True) -> hides rows in which all cells in columns 1-10 contain the exact value "Foo"
'Call hideRows(exampleWS, 1, 1000, "Foo", 1, 10, True, True) -> hides rows in which no cells in columns 1-10 contain the exact value "Foo"
Dim loopCounter As Long
Dim rowCounter As Long
Dim colCounter As Long
Dim endConsRow As Long
Dim tempArr As Variant
Dim toAdd As Long
Dim toHide As String
Dim consBool As Boolean
Dim tempBool As Boolean
Dim rowStr As String
Dim goAhead As Boolean
Dim i As Long
If startRow > endRow Then
toAdd = endRow - 1
Else
toAdd = startRow - 1
End If
ws.Rows(startRow & ":" & endRow).Hidden = False
tempArr = ws.Range(ws.Cells(startRow, startCol), ws.Cells(endRow, endCol)).Value
loopCounter = 1
For rowCounter = LBound(tempArr, 1) To UBound(tempArr, 1)
For colCounter = LBound(tempArr, 2) To UBound(tempArr, 2)
goAhead = False
If tempArr(rowCounter, colCounter) Like valCrit Then
If (Not checkAll) Or (colCounter = UBound(tempArr, 2)) Then
If invert Then
loopCounter = loopCounter + 1
Exit For
End If
goAhead = True
End If
ElseIf checkAll Or colCounter = UBound(tempArr, 2) Then
If Not invert Then
loopCounter = loopCounter + 1
Exit For
End If
goAhead = True
End If
If goAhead Then
endConsRow = rowCounter
consBool = True
Do Until consBool = False
tempBool = False
For i = LBound(tempArr, 2) To UBound(tempArr, 2)
If endConsRow = UBound(tempArr, 1) Then
Exit For
ElseIf tempArr(endConsRow + 1, i) Like valCrit Then
If (Not checkAll) Or (i = UBound(tempArr, 2)) Then
If Not invert Then
endConsRow = endConsRow + 1
tempBool = True
End If
Exit For
End If
ElseIf checkAll Or i = UBound(tempArr, 2) Then
If invert Then
endConsRow = endConsRow + 1
tempBool = True
End If
Exit For
End If
Next
If Not tempBool Then
consBool = False
End If
Loop
rowStr = loopCounter + toAdd & ":" & endConsRow + toAdd
If toHide = "" Then
toHide = rowStr
ElseIf Len(toHide & "," & rowStr) > 255 Then
ws.Range(toHide).EntireRow.Hidden = True
toHide = rowStr
Else
toHide = toHide & "," & rowStr
End If
loopCounter = loopCounter + 1 + (endConsRow - rowCounter)
rowCounter = endConsRow
Exit For
End If
Next
Next
If Not toHide = "" Then
ws.Range(toHide).EntireRow.Hidden = True
End If
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