Excel VBA Running Macros on Foreach Loop without Switching Sheets - vba

I have a module on VBA which basically runs a foreach loop for every cell that contains text in a column. The contents of each cell are then copied to another sheet where another function is called upon (DailyGet). The contents generated from the function are the copied back into the original sheet (i generated the code for this by recordings a macros). However, since there are many cells to process in the foreach loop, it is quite time consuming because the macros switches between sheets each time to run. Is there any way to speed up the process?
Sub DailyComposite()
Dim SrchRng As Range, cel As Range
Set SrchRng = Range("B2:B100")
For Each cel In SrchRng
If cel.Value <> "" Then
Worksheets("Calculations").Range("B1").Value = cel.Value
Sheets("Calculations").Select
Call DailyGet
Range("D3:Z3").Select
Application.CutCopyMode = False
Selection.copy
Sheets("Summary").Select
cel.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
End If
Next cel
Sheets("Calculations").Select
Application.CutCopyMode = False
Range("A1").Select
Sheets("Summary").Select
Range("A1").Select
End Sub

For starters, you can get rid of all the selecting
Range("D3:Z3").Select
Application.CutCopyMode = False
Selection.copy
Sheets("Summary").Select
cel.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Should be:
Sheets("Calculations").Range("D3:Z3").Copy
cel.Offset(0, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Second, why must you switch to the Calculations sheet before running DailyGet. If the function dailyGet uses ActiveSheet, change it to Sheets("Calculations"). If you do that, you never need to switch sheets.
Third, turn off ScreenUpdating when you start the macro, and turn it back on when done:
Application.ScreenUpdating = False

In general you should always avoid select. Instead try and declare/instantiate your variables as shown. I've commented the code below to explain what is going on. Let me know if you have any questions.
Option Explicit 'Always use this it helps prevent simple errors like misspelling a variable
Sub DailyComposite()
'Declare all variables you are going to use
Dim wb As Workbook 'The workbook youa re working with
Dim wsCalc As Worksheet 'Calculations sheet
Dim wsSum As Worksheet 'Summary Sheet
Dim SrchRng As Range, cel As Range
'Instantiate your variables
Set wb = ThisWorkbook
Set wsCalc = wb.Worksheets("Calculations") 'now you can simply use the variable to refer to the sheet NO SELECTING
Set wsSum = wb.Worksheets("Summary") 'SAME AS ABOVE
Set SrchRng = Range("B2:B100")
Application.ScreenUpdating = False 'Turn this off to speed up your macro
For Each cel In SrchRng
If cel.Value <> "" Then
'This ... Worksheets("Calculations").Range("B1").Value = cel.Value becomes...
wsCalc.Range("B1").Value = cel.Value
'Sheets("Calculations").Select ... this line can be deleted
Call DailyGet
'Range("D3:Z3").Select
'Application.CutCopyMode = False
'Selection.Copy
'Sheets("Summary").Select
'cel.Offset(0, 1).Select
'Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
' xlNone, SkipBlanks:=False, Transpose:=False
'All of the above can be replaced by...
wsCalc.Range("D3:Z3").Copy
cel.Offset(0, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End If
Next cel
'You can keep these if you truly want to select the A1 cell at the end
'Sheets("Calculations").Select
wsCalc.Activate
Range("A1").Select
'Sheets("Summary").Select
wsSum.Activate
Range("A1").Select
Application.ScreenUpdating = True 'Turn it back on
End Sub

There is no need to copy and paste values. I select Worksheets("Calculations") to insure that DailyGet will run as before.
Sub DailyComposite()
Dim SrchRng As Range, cel As Range
Set SrchRng = Worksheets("Summary").Range("B2:B100")
With Worksheets("Calculations")
.Select
For Each cel In SrchRng
If cel.Value <> "" Then
Range("B1").Value = cel.Value
Call DailyGet
cel.Offset(0, 1).Resize(, 23).Value = Range("D3:Z3").Value
End If
Next cel
End With
End Sub

Related

Error on automating data entry

I recorded a macro & integrated together with some codes I researched and tested, which worked individually. However, having combined them all together, I stumbled across errors running the macro. Pop out a message box which displays
Compile Error: Expected End With
Would appreciate all the help I could get to solve it
Sub Book1UpdateDelete()
'
' Book1UpdateDelete Macro
'
' Keyboard Shortcut: Ctrl+g
'
'Select values in a column from specified workbook and sheet
Dim LR As Long, cell As Range, rng As Range
Windows("Y738 Data").Activate
With Sheets("Graph data")
LR = .Range("B" & Rows.Count).End(xlUp).Row
For Each cell In .Range("B4:B" & LR)
If cell.Value <> "" Then
If rng Is Nothing Then
Set rng = cell
Else
Set rng = Union(rng, cell)
End If
End If
Next cell
rng.Select
End With
Selection.Copy
'Open next workbook
Windows("Y783").Activate
'Open Sheet L
Sheets("L").Select
'Select empty field fromn column AA
Range("AA" & Rows.Count).End(xlUp).Offset(1).Select
'paste selection to empty field
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Go back to previous workbook & delete column
Windows("Y738").Activate
With Sheets("Graph data")
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Sheets("Graph Data").Select
End Sub
You've missed and end with at the bottom of your code.
Try this (untested)
Sub Book1UpdateDelete()
'
' Book1UpdateDelete Macro
'
' Keyboard Shortcut: Ctrl+g
'
'Select values in a column from specified workbook and sheet
Dim LR As Long, cell As Range, rng As Range
Windows("Y738 Data").Activate
With Sheets("Graph data")
LR = .Range("B" & Rows.Count).End(xlUp).Row
For Each cell In .Range("B4:B" & LR)
If cell.Value <> "" Then
If rng Is Nothing Then
Set rng = cell
Else
Set rng = Union(rng, cell)
End If
End If
Next cell
rng.Select
End With
Selection.Copy
'Open next workbook
Windows("Y783").Activate
'Open Sheet L
Sheets("L").Select
'Select empty field fromn column AA
Range("AA" & Rows.Count).End(xlUp).Offset(1).Select
'paste selection to empty field
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Go back to previous workbook & delete column
Windows("Y738").Activate
With Sheets("Graph data")
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Sheets("Graph Data").Select
End with
End Sub

VBA : error 1004 - Selection and Copy issue

I need your help on something.. I have the 1004 error message (application or object non defined) when running the following code (I put only the critical parts) :
Sub overwrite_CDL()
Dim sht As Worksheet, LastRow As Long
Set sht = ThisWorkbook.Worksheets("JDE_Greece")
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
sht.Activate
Range("M1").AutoFilter Field:=13, Criteria1:="#N/A"
Range("A1:P" & LastRow).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Mismatches").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats,
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
'we want to create a summary sheet with the matches and the N/A:'
sht.Range("M1").AutoFilter Field:=13, Criteria1:="<>#N/A"
sht.Range("A1:P" & LastRow).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Worksheets.Add(After:=Worksheets("Instructions")).Name = "Summary DRP"
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats,
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End Sub
Separately, everything works fine (no error messages, good output) but gives me the error 1004 when running together. The sheet I want to add is no created ("Summary DRP") even if the filters are set correctly.
I think the issue is related to the Selection / Copy but I don't know exactly why (I guess something is not defined properly..).
Can someone help me ? Thanks in advance :)
A few things....
Your code is hard to read without indents (that won't cause an error though).
You set your last row on the currently active sheet, which may not be "JDE_Greece".
After finding the last row, then you activate JDE_Greece.
You copy the selection.
You change sheets.
You paste into whatever cells are selected on the Mismatches sheet (K36:Z36 on my sheet).
You try and select the filtered to <>#N/A cells, but you haven't reselected the sheet yet so it can't select the cells and throws a Select Method of Range class failed error.
The moral of this story.... don't use Select.
So your code with nothing removed, but updated with comments:
Sub overwrite_CDL()
Dim sht As Worksheet, LastRow As Long
Dim sht1 As Worksheet, sht2 As Worksheet '\\New variables
Set sht = ThisWorkbook.Worksheets("JDE_Greece")
Set sht1 = ThisWorkbook.Worksheets("Mismatches") '\\Added reference to Mismatches.
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row '\\Add sheet reference (not really necessary on Rows.Count as row counts should be the same across sheets).
'sht.Activate '\\Don't need to Activate or Select.
sht.Range("M1").AutoFilter Field:=13, Criteria1:="#N/A" '\\Add sheet reference.
sht.Range("A1:P" & LastRow).SpecialCells(xlCellTypeVisible).Copy '\\No need to Select, just copy.
'Selection.Copy '\\Don't need this as incorported into above line.
'Sheets("Mismatches").Select
sht1.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False '\\Added sheet and cell reference.
Application.CutCopyMode = False
'we want to create a summary sheet with the matches and the N/A:'
'\\Moved these two lines after the new sheet is created.
'\\sht.Range("M1").AutoFilter Field:=13, Criteria1:="<>#N/A"
'\\sht.Range("A1:P" & LastRow).SpecialCells(xlCellTypeVisible).Select
'Selection.Copy '\\Don't need this as incorported into above line.
Set sht2 = ThisWorkbook.Worksheets.Add 'Add worksheet and use variable to reference it.
sht2.Name = "Summary DRP"
sht2.Move After:=ThisWorkbook.Worksheets("Instructions")
'Worksheets.Add(After:=Worksheets("Instructions")).Name = "Summary DRP" '\\This row is now the above 3 rows.
sht.Range("M1").AutoFilter Field:=13, Criteria1:="<>#N/A"
sht.Range("A1:P" & LastRow).SpecialCells(xlCellTypeVisible).Copy '\\No need to Select, just copy.
sht2.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False '\\Added sheet and cell reference.
End Sub
And tidied up:
NB: I've removed the extra arguments you entered in the PasteSpecial - these are default values, so get set as that anyway.
Your code will still fail if 'Summary DRP' already exists.
Sub overwrite_CDL()
Dim sht As Worksheet, LastRow As Long
Dim sht1 As Worksheet, sht2 As Worksheet
Set sht = ThisWorkbook.Worksheets("JDE_Greece")
Set sht1 = ThisWorkbook.Worksheets("Mismatches")
With sht
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("M1").AutoFilter Field:=13, Criteria1:="#N/A"
.Range("A1:P" & LastRow).SpecialCells(xlCellTypeVisible).Copy
End With
sht1.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
Set sht2 = ThisWorkbook.Worksheets.Add
With sht2
.Name = "Summary DRP"
.Move After:=ThisWorkbook.Worksheets("Instructions")
End With
With sht
.Range("M1").AutoFilter Field:=13, Criteria1:="<>#N/A"
.Range("A1:P" & LastRow).SpecialCells(xlCellTypeVisible).Copy
End With
sht2.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End Sub

Excel VBA Dynamic Code Repeat Failure

This code is a bit complex but the problem with it is the second and third time it is run it will start to lose columns on the "Base434" worksheet that it pulls information from. I tried a quick fix of adding "Range("A1").Select so that anything previously highlighted couldn't throw it off but it keeps ditching the 20th row which is column "T". I have left all of the code below in hope that someone can find my bug. I just cannot sort it.
Essentially this code sorts set fields of data on an imported worksheet called "Base434", copies specific fields to another page which has some embeded formulas then checks to see if the worksheet "NoStdHC" exists. If it doesn't it will create said worksheet and add the header. Then move to the filtered worksheet called "Base434" and copy all visible cells in that worksheet. It will then paste those in the first available cell in column A of "NoStdHC". My issue is after running this once it refuses to copy the final column on the next "Base434" sheet that has been imported. Can anyone find the fault in my code? Yes I know a lot of this could be condensed if I were better at coding but I would prefer to understand what the code is doing which is why I have it written this way.
Sub NoStdHC()
'
' NoStdHC Macro created by
'
'
Application.ScreenUpdating = False
Sheets("Base434").Select
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
ActiveSheet.Range("A1:T" & LastRow).AutoFilter Field:=15
ActiveSheet.Range("A1:T" & LastRow).AutoFilter Field:=10
ActiveSheet.Range("A1:T" & LastRow).AutoFilter Field:=10, Criteria1:="<=.5", _
Operator:=xlAnd
Columns(11).Cells.SpecialCells(xlCellTypeVisible).Cells(2).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Processing").Select
Range("AC1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("C5").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=COUNTA(C[26])"
Range("e5").Select
ActiveCell.FormulaR1C1 = "=SUM(C[24])"
Range("C8").Select
Sheets("Base434").Select
Dim wsTest As Worksheet
Const strSheetName As String = "PR0OnStd"
Set wsTest = Nothing
On Error Resume Next
Set wsTest = ActiveWorkbook.Worksheets(strSheetName)
On Error GoTo 0
If wsTest Is Nothing Then
Worksheets.Add.Name = strSheetName
Sheets("Base434").Select
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("PR0OnStd").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.Columns.AutoFit
Range("A2").Select
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
End If
Sheets("Base434").Select
Range("a1").Select
Columns(1).Cells.SpecialCells(xlCellTypeVisible).Cells(2).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("PR0OnStd").Select
LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
Range("A" & LastRow).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.ScreenUpdating = True
End Sub'
As commented by #A.S.H avoid using Select/Activate/ActiveCell if at all possible. Ranges should be qualified by using their sheet names. With...End With constructs achieve both of these goals. The With statement allows you to perform a series of statements on a specified object without requalifying the name of the object.
Indentation makes code much easier to read and understand.
With the foregoing in mind I think this code is understandable
Sub NoStdHC()
Dim LastRow As Long
Dim sht As Worksheet
Application.ScreenUpdating = False
With Sheets("Base434")
LastRow = .Cells(Rows.Count, "B").End(xlUp).Row
.Range("A1:T" & LastRow).AutoFilter Field:=10, Criteria1:="<=.5"
.Range(.Cells(2, 11), .Cells(LastRow, 11)).Copy
End With
With Sheets("Processing")
.Range("AC1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Range("C5").FormulaR1C1 = "=COUNTA(C[26])"
.Range("E5").FormulaR1C1 = "=SUM(C[24])"
End With
Dim wsTest As Worksheet
Const strSheetName As String = "PR0OnStd"
'Loop through sheets to find strSheetName
'if not found, then wsTest will be Nothing
For Each sht In ThisWorkbook.Sheets
If sht.Name = strSheetName Then
Set wsTest = ActiveWorkbook.Worksheets(strSheetName)
Exit For
End If
Next
If wsTest Is Nothing Then
'Add the sheet, set up headings, column widths and frozen pane
Worksheets.Add.Name = strSheetName
With Sheets("Base434")
.Range("A1", .Range("A1").End(xlToRight)).Copy
End With
With Sheets("PR0OnStd")
.Range("A1").PasteSpecial xlPasteValues
.UsedRange.Columns.AutoFit
End With
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
.FreezePanes = True
End With
End If
With Sheets("Base434")
.Range(.Cells(2, 1), .Cells(LastRow, 2).End(xlToRight)).Copy
End With
With Sheets("PR0OnStd")
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
.Range("A" & LastRow).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
Application.ScreenUpdating = True
End Sub
If you wanted to write write code you can easily understand you wouldn't write code like this:-
Sheets("Base434").Select
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
This is what your code says, translated into plain language:-
Look at sheet "Base434"
Look at cell A1 (implied: in that sheet)
Look at what you are looking at and extend your view to the last ??? right
(This is where the mistake is)
Copy what you are looking at.
Now, surely, if you wanted to understand what all this looking is aiming to do you might express the idea somewhat like this:-
Copy the cells in Row 1 of Sheet "Base434" from A1 to the end of the row.
With this kind of approach you would end up with code like this:-
Dim RangeToCopy As Range
Dim Cl As Long ' the last used column
With Worksheets("Base434")
Cl = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set RangeToCopy = .Range(.Cells(1, 1), .Cells(1, Cl))
End With
MsgBox "Range to copy = " & RangeToCopy.Address
RangeToCopy.Copy
Would you say that this code is harder to read and understand than your version? Well, it has three advantages, even if it is. One, it doesn't have the fault that yours has. Two, it never got near to wanting to make the mistake that your approach made. Three, whatever errors it might still contain are easy to find and quick to eliminate.
Besides, it runs faster.

VBA for formula to values in a filtered range

Sometimes, I need to run a formula on a selection of a filtered range and then convert it to values, every time I want to copy and then special paste values, I must clear the filters first. I need a macro that will convert the formula to values without clearing the filters, I also want to use a shortcut key for this operation.
The code below will allow this operation, the CTRL+M shortcut is available for this operation. Edit the macro to assign this shortcut key.
Sub PasteFilterValues()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If Selection.Cells.Count = 1 Then
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Else
Dim rng As Range
Set rng = Selection.SpecialCells(xlCellTypeVisible)
For Each cl In rng
cl.Copy
cl.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next cl
rng.Select
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.CutCopyMode = False
End Sub
This should be faster than the other solution
Option Explicit
Sub fla2values(rng As Range)
Dim c As Range
For Each c In rng.SpecialCells(xlCellTypeVisible)
c.Value = c.Value
Next c
End Sub
Sub test_fla2values()
fla2values Selection
End Sub

copy row in vba - add the same autonumber to few rows

I try to copy in the excel few rows to a table, and give the same auto number to the rowa I add in each opparation.
I have a macro that copy the rows and gives the first line (of the new lines I just added) the next auto number. I want to add the same number to the other rows. (and each time there can be different numbers of rows, but not more then 16).
my macro is:
Sub copy_order()
'
'
Sheets("orders").Select
Application.Goto Reference:="product"
ActiveCell.Range("A1:D16").Select
Selection.Copy
Application.Goto Reference:="orders_table"
Selection.End(xlDown).Select
ActiveCell.Offset(1, 1).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Offset(0, -1).Range("A1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=R[-1]C+1"
ActiveCell.Offset(1, 0).Range("A1").Select
Application.Goto Reference:="product"
ActiveCell.Offset(0, 0).Range("A1:C1").Select
Selection.ClearContents
Application.Goto Reference:="orders_table"
End Sub
thank you, Keren.
Not sure I followed all your offsets correctly, but this should get you close...
Sub copy_order()
Dim rngDest As Range, rngCopy As Range, sht As Worksheet, num
Dim c As Range
Set sht = Sheets("orders")
Set rngCopy = sht.Range("product").Range("A1:D16")
Set rngDest = sht.Range("orders_table").Cells(1).End(xlDown).Offset(1, 0)
rngDest.Resize(rngCopy.Rows.Count, rngCopy.Columns.Count).Value = rngCopy.Value
num = rngDest.Offset(-1, -1).Value + 1
Do While Application.CountA(rngDest.Resize(1, rngCopy.Columns.Count)) > 0
rngDest.Offset(0, -1).Value = num
Set rngDest = rngDest.Offset(1, 0)
Loop
End Sub