Sub insertMultipleRows()
'code disables excel while macro runs'
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim rowcount As Integer
rowcount = Application.InputBox(Prompt:="how many rows do you want to insert" & ActiveCell.Row & "?", Type:=1)
'handle error for instances when row count may be negative or zero'
If rowcount <= 0 Then End
Rows(ActiveCell.Row & ":" & ActiveCell.Row + rowcount – 1).Insert Shift:=xlDown
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
LOL. Spent ages scratching my head on this one. As I saw it there was no reason why this code wouldn't work. I copied your code into VBA and the below line should up red:
Rows(ActiveCell.Row & ":" & ActiveCell.Row + rowcount – 1).Insert Shift:=xlDown
For the life of me I couldn't see why and it didn't make any sense.
I deleted the line and manually typed it and everything worked fine! What the ....
Decided to paste the line from above under the line I typed and this is what I got:
Curiouser and curioser! I pasted both line into Text Comparer https://text-compare.com/ and there it was! You're using the wrong minus Character. What you're using is the ASCII 150 Character instead of the standard ASCII 45 character.
Here's the proper code:
Rows(ActiveCell.Row & ":" & ActiveCell.Row + rowcount - 1).Insert Shift:=xlDown
Related
I have some VBA code written that runs quite slowly. I have a series of different loops in my code. I know that loops aren't always the most efficient way to manipulate data, so I think they are the problem. I need ideas for how to either alter the loop or eliminate it so I can speed up the run time of my code.
Below is the most active loop I have created. It's running through all of the cells on row D (starting in D2) and manipulating their values based off of entries in the cells in row 1. If I can get help on this loop I'll probably be able to use similar techniques to alter the other loops in my code. Any tips are appreciated.
'sub work week for date range
Range("D2").Select
Do Until IsEmpty(ActiveCell.Value)
If IsEmpty(ActiveCell.Offset(-1, 0)) = False Then
ActiveCell.Value = ActiveCell.Offset(-1, 0).Value & "-" & Right(ActiveCell.Value, 4)
Else: ActiveCell.Value = ActiveCell.Value & "-" & Right(ActiveCell.Offset(0, -1), 4)
End If
ActiveCell.Offset(0, 1).Select
Loop
The fastest, and more efficient method, would be as has been suggested in the comments by using arrays.
To get you to that point though, I've given you the first steps to improving your interaction with VBA and understanding how to write your code without selecting or activating objects:
For i = 4 To Cells(2, Columns.Count).End(xlToLeft).Column
With Cells(2, i)
If .Offset(-1, 0).Value = vbNullString Then
.Value = .Value & "-" & Right$(.Offset(0, -1).Value, 4)
Else
.Value = .Offset(-1, 0).Value & "-" & Right$(.Value, 4)
End If
End With
Next
Basically, you don't need to .Select or .Activate anything. Work with the objects directly and use a variable to dictate the column rather than activating the next cell.
Once you're comfortable with writing code in this style, look at assigning a range's value to a 2D array and then loop through the array instead.
For fast execution, my first recommendation is to turn automatic calculation and screen-updating off too if it still takes long.
I agree that anything that involves selecting is going to be incredibly slow so you should use range objects instead.
Final code:
' Declarations
Dim CurrentCell, LeftCell, PreviousCell As Range
Dim Last4Chars As String
'Initialize
Set CurrentCell = ActiveSheet.Range("D2")
'Optimizations
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'Loop until Current Cell in Empty
Do Until IsEmpty(CurrentCell.Value)
Set AboveCell = CurrentCell.Offset(-1, 0) 'One row above
Set LeftCell = CurrentCell.Offset(0, -1) 'One column left
If IsEmpty(AboveCell) = False Then
CurrentCell.Value = AboveCell.Value & "-" & Right(CurrentCell.Value, 4)
Else
CurrentCell.Value = CurrentCell.Value & "-" & Right(LeftCell, 4)
End If
Set CurrentCell = CurrentCell.Offset(0, 1)
Loop
'Optimizations reversed for normal use
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
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
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
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.