I created a conditional formatting formula
=AND(SUMPRODUCT(($A$2:$A$" & lastRow & "=$A2)*($CT$2:$CT$" & lastRow & "=$CT2)*($CU$2:$CU$" & lastRow & "=$CU2)*($CV$2:$CV$" & lastRow & "=$CV2)*($CW$2:$CW$" & lastRow & "=$CW2))>1,$CT2 <> """")"
To find & highlight duplicate upcharges based on multiple criteria:
Product's XID (Column A), Upcharge Criteria 1 (Column CT), Upcharge Criteria 2 (Column CU), Upcharge Type (Column CV), and Upcharge Level (Column CW). The formula works like a charm highlighting upcharges that are duplicates; however, much of the time I have to apply it to a large number of rows (upwards of 15000) and it takes 10+ minutes to apply the conditional format formula. I was curious if there is a quicker way of applying this formula to that many cells. My entire code for reference is
'File Complete, highlights duplicate upcharges for products and skips over blank upcharge rows
Sub dupUpchargeCheck()
Dim lastRow As Integer
lastRow = ActiveSheet.Cells(Rows.Count, "CS").End(xlUp).Row
ActiveSheet.Range("CS2:CS" & lastRow).Select
With ActiveSheet.Range("CS2:CS" & lastRow)
.FormatConditions.Add Type:=xlExpression, Formula1:="=AND(SUMPRODUCT(($A$2:$A$" & lastRow & "=$A2)*($CT$2:$CT$" & lastRow & "=$CT2)*($CU$2:$CU$" & lastRow & "=$CU2)*($CV$2:$CV$" & lastRow & "=$CV2)*($CW$2:$CW$" & lastRow & "=$CW2))>1,$CT2 <> """")"
.FormatConditions(.FormatConditions.Count).Interior.ColorIndex = 3
End With
End Sub
Any advice is appreciated!
EDIT:
After toying around a bit, I've realized my problem isn't with the application of the conditional formatting formula to the range of cells, but actually when I click the drop down to filter on the color (after the code is ran and the conditional formatting is applied) it takes forever for the filter dropdown box to appear (I assume because all of the formulas calculating at that time?). Any idea how I can get around that issue? I've tried one of #Nate suggestions of
calcState = Application.Calculation, placing it right before the line where I filtered (via vba) in hopes that it would stop the calculations from running as the system attempted to show the filter box, but it still takes forever. With the addition Application.ScreenUpdating = False the processing time takes slightly less time (timed around 551 seconds for 15000 rows). I'm afraid that might be the best I'll be able to get it unless someone else has any suggestions?
Try turning off some Excel features before your code then turning them back on when it is done.
' turn off unnecessary excel features, put before your code
screenUpdateState = Application.ScreenUpdating
statusBarState = Application.DisplayStatusBar
calcState = Application.Calculation
eventsState = Application.EnableEvents
displayPageBreakState = ActiveSheet.DisplayPageBreaks
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Then
' Turn features back on
Application.ScreenUpdating = screenUpdateState
Application.DisplayStatusBar = statusBarState
Application.Calculation = calcState
Application.EnableEvents = eventsState
ActiveSheet.DisplayPageBreaks = displayPageBreaksState
This didn't help me before, but I hope it help you as this link said :
This is particularly useful when condition is applied over a large range as performance can be slow in these cases.
ActiveSheet.EnableFormatConditionsCalculation = False
'.....
ActiveSheet.EnableFormatConditionsCalculation = True
Maybe this not work on MAC.
ActiveSheet.EnableFormatConditionsCalculation Not Supported in VBA for Excel 2011 on the Mac
Related
I am a newcomer to vba/excel macros and need a more efficient way to run the below code. I am using a for each loop to return a value from a row based on a column's value (same row). The code works, but takes far too much processing power and time to get through the loops (often freezing the computer or program). I would appreciate any suggestions...
'The following is searching each cell in a range to determine if a cell is not empty. If the cell is not empty, the macro will copy the value of the cell and paste it in to another worksheet (same row)
Set rng = Worksheets("Demographic").Range("AU2:AU" & lastRow)
i = "2"
For Each cell In rng
If Not IsEmpty(cell.Value) Then
Sheets("Demographic").Range("AU" & i).Copy
Sheets("Employee import").Range("F" & i).PasteSpecial xlPasteValues
End If
i = i + 1
Next
'The following is searching each cell in a range to determine if a cell contains a "T". If the cell contains a "T", the macro will copy the value of a different column (same row) and paste it in to another worksheet (same row)
Set rng = Worksheets("Demographic").Range("AM2:AM" & lastRow)
i = "2"
For Each cell In rng
If cell.Value = "T" Then
Sheets("Demographic").Range("AO" & i).Copy
Sheets("Employee import").Range("G" & i).PasteSpecial xlPasteValues
End If
i = i + 1
Next
A formula array should be your best hope. This supposes that the cells that do not match will lead to empty values in the destination range:
chk = "Demographic!AU2:AU" & lastRow
src = "Demographic!AU2:AU" & lastRow
With Sheets("Employee import").Range("F2:F" & lastRow)
.FormulaArray = "=IF(" & chk & "<> """"," & src & ", """")"
.Value = .Value '<-- if you want to remove the formulas and keep only the copied values
End With
chk = "Demographic!AM2:AM" & lastRow
src = "Demographic!AO2:AO" & lastRow
With Sheets("Employee import").Range("G2:G" & lastRow)
.FormulaArray = "=IF(" & chk & "= ""T""," & src & ", """")"
.Value = .Value '<-- if you want to remove the formulas and keep only the copied values
End With
Not sure that it will be faster with your dataset though, you can only verify by trying it.
If you just want a straight data transfer (ie no formulas or formats), and your data set is large, then you could consider writing the data in one batch by way of an array.
Your own code shouldn't be horrendously slow though, so it suggests you have some calculations running or maybe you're handling Worksheet_Change events. If this is possible, then you might want to disable those during the data transfer:
With Application
.EnableEvents = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Just remember to reset them at the end of your routine:
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
If you went the array route, skeleton code would be like so:
Dim inData As Variant
Dim outData() As Variant
Dim r As Long
'Read the demographic data
With Worksheets("Demographic")
inData = .Range(.Cells(2, "AU"), .Cells(.Rows.Count, "AU").End(xlUp)).Value2
End With
'Use this if your column F is to be entirely overwritten
ReDim outData(1 To UBound(inData, 1), 1 To UBound(inData, 2))
'Use this if you have exisiting data in column F
'With Worksheets("Employee import")
' outData = .Cells(2, "F").Resize(UBound(inData, 1)).Value2
'End With
'Pass the values across
For r = 1 To UBound(inData, 1)
If Not IsEmpty(inData(r, 1)) Then
outData(r, 1) = inData(r, 1)
End If
Next
'Write the new values
Worksheets("Employee import").Cells(2, "F").Resize(UBound(outData, 1)).Value = outData
as for your first copy/paste values, it actually doesn't need any check, since blank values would be pasted as blank ones...
so you could go:
With Worksheets("Demographic")
With .Range("AU2", .Cells(.Rows.count, "AU").End(xlUp))
Worksheets("Employee import").Range("F2").Resize(.Rows.count).Value = .Value
End With
End With
as for your 2nd copy/paste values, you could paste all values and then filter not wanted ones and clear them in target sheet
like follows:
With Worksheets("Demographic")
With .Range("AM2", .Cells(.Rows.count, "AM").End(xlUp))
Worksheets("Employee import").Range("G2").Resize(.Rows.count).Value = .Offset(, 2).Value
End With
End With
With Worksheets("Employee import")
With .Range("G1", .Cells(.Rows.count, "G").End(xlUp))
.AutoFilter field:=1, Criteria1:="<>T"
.Resize(.Rows.count).Offset(1).SpecialCells(xlCellTypeVisible).ClearContents
End With
.AutoFilterMode = False
End With
that said, if your workbook has many formulas and/or event handlers then you would also greatly benefit from disabling them (Application.EnableEvents = False, Application.Calculation = xlCalculationManual) before running your code and enabling them back (Application.EnableEvents = True, Application.Calculation = xlCalculationAutomatic) after you code completes
This question already has answers here:
How to "flatten" or "collapse" a 2D Excel table into 1D?
(9 answers)
Closed 6 years ago.
Currently I have a data-set of 4000 rows with data arranged below:
The format it needs to be in is like this:
I have ignored the dates field or the X,Y,Z fields at the moment and just want to focus on the rows. I'm new to VBA still so please bear with my explanations.
My understanding of this is that I should use a variant to store the data as 1-dimensional arrays and then cycle through this via a for-loop.
This is what my code attempts to do (albeit clumsily):
Sub TransposeData()
Dim Last As Variant
Application.ScreenUpdating = False
prevCalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
Last = Cells(Rows.Count, "L").End(xlUp).Row
'Go to the very bottom of row L and get the count
'For i = row Count - 1 from this and check what the value of L is
'If the value of L is greater than 0 Then ...
For i = Last To 1 Step -1
If (Cells(i, "L").Value) > 0 Then
range("D" & i & ":L" & i).Copy
Sheets("test").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Sheets("CVM").Select
End If
Next i
Application.Calculation = prevCalcMode
Application.ScreenUpdating = True
End Sub
However I am stuck at setting my 'range' variable as I don't know how to make it specific to each iteration. i.e. Range(i,L) This will not work obviously but I can't seem to think of another way around this.
Could you please point me in the right direction? I did look at a few other VBA questions regarding this but I couldn't apply the same methodology to my issue.
(Transpose a range in VBA)
Thank you!
EDIT: I now have my macro starting to work (yay!), but the loop keeps over-writing the data. Is there a way to check where the data was last pasted and make sure you paste in the next blank part of the column?
Seeing as you are new to VBA, as you said.
A few things:
Always use indexed based reference, like you used for range("D" & i & ":L" & i).Copy but then you did not use it for the PasteSpecial
Make sure you use referencing to the specific sheet you are wanting to operate out of, this way VBA doesnt need to assume anything
Try use descriptive variables this helps the next user really understand your code.
Also Use Option Explicit ALWAYS, I did no like it in the beginning but once I was used to typing correct variables for everything, like we should, its not an issue anymore. To have the Option Explicit on every module just go
Tool >> Options >> Require Variable Declaration
See answer below
Option Explicit
Sub TransposeData()
Application.ScreenUpdating = False
Dim PrevCalcMode As Variant
PrevCalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
Dim DataSheet As Worksheet
Set DataSheet = ThisWorkbook.Sheets("CVM")
Dim DestinationSheet As Worksheet
Set DestinationSheet = ThisWorkbook.Sheets("test")
Dim DataSheetLastCell As Variant
With DataSheet
DataSheetLastCell = .Cells(.Rows.Count, "L").End(xlUp).Row
End With
Dim DataSheetRowRef As Long
Dim DestinationSheetNextFreeRow As Long
For DataSheetRowRef = 2 To DataSheetLastCell
If Not DataSheet.Cells(DataSheetRowRef, "L") = Empty Then
DataSheet.Range("D" & DataSheetRowRef & ":L" & DataSheetRowRef).Copy
With DestinationSheet
DestinationSheetNextFreeRow = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
.Cells(DestinationSheetNextFreeRow, "B").PasteSpecial Transpose:=True
End With
End If
Next DataSheetRowRef
Application.ScreenUpdating = True
PrevCalcMode = Application.Calculation
End Sub
Now I spent a few days searching up and down and need to find a solution.
I saw two threads but both are not what I am looking for exactly and I admit, being not too good in VBA, I cant make heads or tales.
What I have:
I have 4300 lines of Bank statements. There are multiple columns but 1 is of importance - Description. This description might contain a lot of things, but usually there is 1 key word that is crucial. Roughly 96% can be automated and 3-4% just written manually every now and then.
What I want:
A VBA Macro that will read the column description, will match a keyword there from a list of many such in Sheet2, column "keywords" and then write in Column Category (sheet1) the assigned Categorizaion taken from Column Category on Sheet2.
What I have done so far:
the only thing I found to be working for me, and be able to actually reproduce is using a formula:
=IF(ISNUMBER(SEARCH("KEYWORD",[Description])),"OUTPUT","")
The above formula was repeated multiple times but this slows and lags everything. Besides being unmanagable.
Its working but I need something better. So -> enter Macros. and here I am lost.
I found that the answer of #JohnBustos is very good here:
How to group excel items based on custom rules?
but not working for me really.
I found the answer of Tomk Dallimore to be what I need or want:
Categorizing bank transactions in Excel
but I cant make heads or tales how to get there??? He is very detailed but I am getting lost on the complexity which mind you is great.
Can you please help me?
I am attaching a very simple example of what I am talking.
http://1drv.ms/1Putpy5
Note#1
I founnd a new formula that I incorporated.
'=IFERROR(LOOKUP(10^10,SEARCH(" "&KeywordTable[In-keyword]&" "," "&H29& " "),KeywordTable[Out-keyword ]),"")
But this is also troubling the CPU as it calculates each time a cell is moved. I imagine it will throw exception if I add 560 new rows or better yet move the table with 1 poisition. Temporary solution but need something more sophisticated.
*****possibly a terrible idea****
To speed up the macro, such macro as the one you provided in your answer, is it possible to make it work like the automatic date filler macro:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
With Target
If .Count > 1 Then Exit Sub
If Not Intersect(Range("B2:B100"), .Cells) Is Nothing Then
Application.EnableEvents = False
If IsEmpty(.Value) Then
.Offset(0, 3).ClearContents
Else
With .Offset(0, 3)
.NumberFormat = "dd mmm yyyy hh:mm:ss"
.Value = Now
End With
End If
Application.EnableEvents = True
End If
End With
End Sub
Of course, I realize I am asking for something strange but if this can happen it will be rather fast and extremely helpful for optimzing the speed at which the macro is executed for large amounts of data. Now, I have 4500 rows to calculate. Within 2 months, this amount will double.
Based on your excel file this code works: 10'000 rows done in 3 secondes with this code.
Sub test()
Dim lastrow As Long, lastrow2 As Long
Dim i As Integer, j As Integer
Dim PatternFound As Boolean
Call speedup
lastrow = Sheets("Keywords").Range("A" & Rows.Count).End(xlUp).Row
lastrow2 = Sheets("SOURCE DATA").Range("E" & Rows.Count).End(xlUp).Row
For i = 4 To lastrow2
PatternFound = False
j = 1
Do While PatternFound = False And j < lastrow
j = j + 1
If UCase(Sheets("SOURCE DATA").Range("E" & i).Value) Like "*" & UCase(Sheets("Keywords").Range("A" & j).Value) & "*" Then
Sheets("SOURCE DATA").Range("F" & i).Value = Sheets("Keywords").Range("B" & j).Value
PatternFound = True
End If
Loop
Next i
Call normal
End Sub
Public Sub speedup()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
End Sub
Public Sub normal()
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
I am using the following vba code to change a text string date into an actual date in excel so I can use it for logical comparisons and the like.
The problem is I need this to work for around 4000 rows and update it weekly, and this code is very slow.
Sub Datechange()
Dim c As Range
For Each c In Range("D2:D" & Range("D" & Rows.Count).End(xlUp).Row)
c.Value = CDate(c.Value)
Next c
End Sub
Are there any alternative ways I could do the same thing quicker? I am assuming part of the reason it is so slow is because there are overheads involved with selecting single cells and processing the code over and over but I am not sure how to do it any other way?
Also some of the rows at the bottom contain the words "None Specified" and when the code reaches these cells it breaks with
Run-time error '13': Type mismatch
Is there a way to stop this happening so the following code can complete?
First steps would be:
Turn screen updating off
Turn calculation off
Read and write the range at once
It could look like the code below - it is a good idea to include an error handler to avoid leaving your spreadsheet with screen updates off or with the calculation mode changed:
Sub Datechange()
On Error GoTo error_handler
Dim initialMode As Long
initialMode = Application.Calculation 'save calculation mode
Application.Calculation = xlCalculationManual 'turn calculation to manual
Application.ScreenUpdating = False 'turn off screen updating
Dim data As Variant
Dim i As Long
'copy range to an array
data = Range("D2:D" & Range("D" & Rows.Count).End(xlUp).Row)
For i = LBound(data, 1) To UBound(data, 1)
'modify the array if the value looks like a date, else skip it
If IsDate(data(i, 1)) Then data(i, 1) = CDate(data(i, 1))
Next i
'copy array back to range
Range("D2:D" & Range("D" & Rows.Count).End(xlUp).Row) = data
exit_door:
Application.ScreenUpdating = True 'turn screen updating on
Application.Calculation = initialMode 'restore original calculation mode
Exit Sub
error_handler:
'if there is an error, let the user know
MsgBox "Error encountered on line " & i + 1 & ": " & Err.Description
Resume exit_door 'don't forget the exit door to restore the calculation mode
End Sub
It would be better to get the values in to an array in one single "pull", operate on the array and write it back.
That would circumvent the expensive range operation.
dim c as range
set c = Range("D2:D" & Range("D" & Rows.Count).End(xlUp).Row)
dim ArrValue() as Variant
set ArrValue = c.value
next step: iterate over that array and then write back:
c.value = Arrvalue
I have no time to test the code, so please correct it for yourself, I am sorry.
Here an absolute beginner at any form of coding, this is the first time ever I try to use VBA.
I have managed after a week and a half of searching and testing and learning to reach the below posted code and I have hit a WALL (and I'm not even done yet!)
What I am trying to achieve:
Compare the data in sheet1 with the data in sheet2 found in Columns K respectively A (there are ca. 55.000 rows in K and 2500 in A) the data might repeat itself as these are product codes and it's ok as at the end of this I want to be able to see which ones have expired.
so .. If K = A then it has to copy adjacent values found in Sheet2 - columns O, P & Q and Paste them in Sheet2 - Columns O, P & Q and if no match is found then right not found. In the Example below I have only tried to copy Q, it would probably take forever if I tried adding O & P.
(Note: I have found this code in one of the forms here and used it after trying different other ways with select/ Copy/ Paste etc. but none have worked)
Later I would like to try adding another column in Sheet1 and based on the Date which will be copied to Sheet1 and into column P populate it with Expired or Soon to be expired depending on the case, but this is an entire different story and I haven't even begun thinking how to do it.
The problem is that my current code takes over an hour and it's still not finished yet while I am writing this!!! And I do not understand where have I gone wrong ....
Dim lastRow1 As Long
Dim lastRow2 As Long
Dim tempVal As String
lastRow1 = Sheets("Sheet1").Range("K" & Rows.Count).End(xlUp).Row
lastRow2 = Sheets("Sheet2").Range("A" & Rows.Count).Row
For sRow = 2 To lastRow1
tempVal = Sheets("MatCode").Cells(sRow, "A").Text
For tRow = 2 To lastRow2
If Sheets("Sheet1").Cells(tRow, "K") = tempVal Then
Sheets("Sheet1").Cells(tRow, "Q") = Sheets("Sheet2").Cells(sRow, "Q")
End If
Next tRow
Next sRow
Dim match As Boolean
'now if no match was found, then put NO MATCH in cell
For lRow = 2 To lastRow2
match = False
tempVal = Sheets("Sheet1").Cells(lRow, "K").Text
For sRow = 2 To lastRow1
If Sheets("Sheet2").Cells(sRow, "A") = tempVal Then
match = True
End If
Next sRow
If match = False Then
Sheets("Sheet1").Cells(lRow, "Q") = "NO MATCH"
End If
Next lRow
End Sub
I have also used:
With Application
.AskToUpdateLinks = False
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
To make sure nothing stands in the way.
Please Help!
This will loop through rows to match column A on Sheet1 with column K on sheet2. On a non-match "No Match" will be put in Sheet1 column Q.
On a match Sheet2 columns O,P and Q will be copied to Sheet1 columns O,P and Q.
This took about 10 seconds to run for over 12k in column A and over 2500 in column K.
Sub match_columns()
Dim I, total, fRow As Integer
Dim found As Range
total = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
For I = 1 To total
answer1 = Worksheets(1).Range("A" & I).Value
Set found = Sheets(2).Columns("K:K").Find(what:=answer1) 'finds a match
If found Is Nothing Then
Worksheets(1).Range("Q" & I).Value = "NO MATCH"
Else
fRow = Sheets(2).Columns("K:K").Find(what:=answer1).Row
Worksheets(1).Range("O" & I).Value = Worksheets(2).Range("O" & fRow).Value
Worksheets(1).Range("P" & I).Value = Worksheets(2).Range("P" & fRow).Value
Worksheets(1).Range("Q" & I).Value = Worksheets(2).Range("Q" & fRow).Value
End If
Next I
End Sub
Thank you again #Mooseman for providing the solution!
I only had to change Range A with K, at first even so I was not able to make it work as it copied only the first line. I already had some code which opened the Worksheets and copied them to a new Worksheet/added new columns ..etc., to be SavedAs for later use, and it seems that because of this your code was not able to loop properly (not sure how to explain this) in any case at the end of the open / save workbooks ..etc I have introduced a Call Sub Procedure which worked like a charm!
Also, introduced two extra lines to properly format columns O and P as Date.
I am sure it could have looked better than this, but so far it works!
And thank you to everyone who provided me with suggestions, there is still a lot to learn and I am planning to test other ways just for the sake of learning, but I needed this to work now.
Sub Button1_Click()
With Application
.AskToUpdateLinks = False
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
'Code to Open / Save / introduce new columns into Sheet(1)
Call match_columns
End Sub
Sub match_columns()
Dim I, total, frow As Integer
Dim found As Range
total = Sheets(1).Range("K" & Rows.Count).End(xlUp).Row
'MsgBox (total) --> used to test if it can count/see the total number of rows
For I = 2 To total
answer1 = Worksheets(1).Range("K" & I).Value
Set found = Sheets(2).Columns("A:A").Find(what:=answer1) 'finds a match
If found Is Nothing Then
Worksheets(1).Range("Q" & I).Value = "NO MATCH"
Else
frow = Sheets(2).Columns("A:A").Find(what:=answer1).Row
Worksheets(1).Range("O" & I).Value = Worksheets(2).Range("O" & frow).Value
Worksheets(1).Range("P" & I).Value = Worksheets(2).Range("P" & frow).Value
Worksheets(1).Range("Q" & I).Value = Worksheets(2).Range("Q" & frow).Value
End If
Next I
Worksheets(1).Range("P2", "P" & total).NumberFormat = "dd.mm.yyyy"
Worksheets(1).Range("O2", "O" & total).NumberFormat = "dd.mm.yyyy"
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.AskToUpdateLinks = True
.Calculation = xlCalculationAutomatic
End With
End Sub
This is slow because your macro is iterating through 55,000 * 2,500 rows of data, twice. That's 275,000,000 cycles.
I think the solution is to scrap the macro and use VLOOKUP or Index Match.
You could add this formula to cell Q2 of sheet1:
=IFERROR(INDEX(Sheet2!$Q:$Q,MATCH(Sheet1!$K2,Sheet2!$A:$A,0)),"NO MATCH")
That is how I would do this. If you need it to be a macro, you can write a macro that just sets Sheet1 K2 to have this formula and drag the formula down.