I have the following Macro:
Sub PercentCalc()
Dim xrng As Range, lrw As Long, lrng As Range, i As Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
For i = 1 To 25
With Columns(i)
.TextToColumns Destination:=.Cells(1, 1), DataType:=xlDelimited, TrailingMinusNumbers:=True
End With
Next
lrw = Columns("A:Y").Find("*", , xlValues, , xlRows, xlPrevious).Row
Set lrng = Range("A" & lrw + 2)
With Range("A2:A" & lrw)
lrng.Formula = "=COUNTA(" & .Address(0, 0) & ")/ROWS(" & .Address(0, 0) & ")"
End With
Set xrng = Range(lrng, Cells(lrng.Row, "Y"))
lrng.AutoFill xrng, Type:=xlFillDefault
xrng.Style = "Percent"
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
How can I apply this across multiple worksheets in a workbook? Or multiple workbooks with multiple worksheets? I have a macro to open all Excel files in my directory. Even better if I could bypass opening all Excel files.
Pretty much want to automate this macro within a large amount of files/sheets.
You can't calculate without opening all the workbooks, but there is a simple command for what you are looking for: Application.CalculateFull. It re-calculates all sheets in all open workbooks. Be aware that this may take a long time and may make Excel seem like it is not responding until it finishes. In addition, if the open sheets are in a different instance of Excel from your macro above, they will not calculate.
So I would imagine your process to look like this:
Run your macro to open all the files
Run your macro above, with .CalculateFull just after .Calculation = xlCalculationAutomatic and just before End With, End Sub
Related
I am new to VBA and I have some code which I have written and although it works I think it is bulky and not very good should a change ever need to be made to it.
The code opens a spreadsheet, runs a Function (Called "LastRow") to copy the data and another (Called "NxtRow")to paste it into the next empty row of the spreadsheet with the macro then closes the sheet that the data was copied from and moves on to the next one. Basically it is concatenating multiple sheets into one.
I am thinking that there must be a way to write the code to call the functions once and then loop through each sheet in a list. Is this possible?
My code is:
NxtRow() Function
Public Function NxtRow()
Dim BlankRow As Long
Windows("GA_BudgetTool_MASTER.xlsm").Activate
BlankRow = Range("A" & Rows.Count).End(xlUp).Row + 1
Cells(BlankRow, 1).Select
ActiveSheet.Paste
BlankRow = Range("A" & Rows.Count).End(xlUp).Row + 1
Cells(BlankRow, 1).Select
End Function
LstRow() Function
Public Function LastRow()
Dim LstRow As Long, LstCol As Long, Rng As Range, A3 As Range
LstRow = Range("A" & Rows.Count).End(xlUp).Row
LstCol = Range("O" & LstRow).Column
Set Rng = Range(Cells(LstRow, 1), Cells(LstRow, LstCol))
Set A3 = Range("A3")
Range(A3, Rng).Select
Selection.Copy
End Function
VBA Sub()
Sub ImpData()
' Deactivate Screen Updating and Display Alerts
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Import Worksheet 1
Workbooks.Open Filename:= _
"Worksheet1_Filename.xlsx"
LastRow
NxtRow
Windows("Worksheet1.xlsx").Activate
ActiveWindow.Close
' Import Worksheet 2
Workbooks.Open Filename:= _
"Worksheet2_Filename.xlsx"
LastRow
NxtRow
Windows("Worksheet2.xlsx").Activate
ActiveWindow.Close
' Import Worksheet 3
Workbooks.Open Filename:= _
"Worksheet3_Filename.xlsx"
LastRow
NxtRow
Windows("Worksheet3.xlsx").Activate
ActiveWindow.Close
This goes on in this fashion for about 30 sheets. Is there an easier way to write this and make it easier to amend later if needed?
I would just make a little array of your filenames and then use a for loop to repeat the function calls as many times as necessary
Sub ImpData()
'Deactivate Screen Updating and Display Alerts
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Dim filenames As Variant
filenames = Array("file1", "file2")
For i = 1 To UBound(filenames) + 1
Workbooks.Open Filename:=filenames(i - 1)
LastRow
NxtRow
Windows("Worksheet" & i & ".xlsx").Activate
ActiveWindow.Close
Next i
'Reactivate Screen Updating and Display Alerts
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
I am trying to write code for a project. There is a preexisting template from the client. I need to create new files by dividing one master excel file into new files. The files must use the template which has multiple worksheets. The data will be separated by Identification numbers, but some files will have thousands of data rows. I am trying to write visual basic code to create the files, but am having some difficulty. Any suggestions are greatly appreciated.
Something like this should be pretty close.
Sub Copy_With_AutoFilter2()
'Note: This macro use the function LastRow
'Important: The DestSh must exist
Dim My_Range As Range
Dim DestSh As Worksheet
Dim CalcMode As Long
Dim ViewMode As Long
Dim FilterCriteria As String
Dim CCount As Long
Dim rng As Range
'Set filter range on ActiveSheet: A1 is the top left cell of your filter range
'and the header of the first column, D is the last column in the filter range.
'You can also add the sheet name to the code like this :
'Worksheets("Sheet1").Range("A1:D" & LastRow(Worksheets("Sheet1")))
'No need that the sheet is active then when you run the macro when you use this.
Set My_Range = Range("A1:D" & LastRow(ActiveSheet))
My_Range.Parent.Select
'Set the destination worksheet
'Note: the sheet "RecordsOfTheNetherlands" must exist in your workbook
Set DestSh = Sheets("RecordsOfTheNetherlands")
If ActiveWorkbook.ProtectStructure = True Or _
My_Range.Parent.ProtectContents = True Then
MsgBox "Sorry, not working when the workbook or worksheet is protected", _
vbOKOnly, "Copy to new worksheet"
Exit Sub
End If
'Change ScreenUpdating, Calculation, EnableEvents, ....
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False
'Firstly, remove the AutoFilter
My_Range.Parent.AutoFilterMode = False
'Filter and set the filter field and the filter criteria :
'This example filter on the first column in the range (change the field if needed)
'In this case the range starts in A so Field 1 is column A, 2 = column B, ......
'Use "<>Netherlands" as criteria if you want the opposite
My_Range.AutoFilter Field:=1, Criteria1:="=Netherlands"
'If you want to filter on a cell value you can use this, use "<>" for the opposite
'This example uses the activecell value
'My_Range.AutoFilter Field:=1, Criteria1:="=" & ActiveCell.Value
'This will use the cell value from A2 as criteria
'My_Range.AutoFilter Field:=1, Criteria1:="=" & Range("A2").Value
''If you want to filter on a Inputbox value use this
'FilterCriteria = InputBox("What text do you want to filter on?", _
' "Enter the filter item.")
'My_Range.AutoFilter Field:=1, Criteria1:="=" & FilterCriteria
'Check if there are not more then 8192 areas(limit of areas that Excel can copy)
CCount = 0
On Error Resume Next
CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
On Error GoTo 0
If CCount = 0 Then
MsgBox "There are more than 8192 areas:" _
& vbNewLine & "It is not possible to copy the visible data." _
& vbNewLine & "Tip: Sort your data before you use this macro.", _
vbOKOnly, "Copy to worksheet"
Else
'Copy the visible data and use PasteSpecial to paste to the Destsh
With My_Range.Parent.AutoFilter.Range
On Error Resume Next
' Set rng to the visible cells in My_Range without the header row
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then
'Copy and paste the cells into DestSh below the existing data
rng.Copy
With DestSh.Range("A" & LastRow(DestSh) + 1)
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
' Remove this line if you use Excel 97
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
'Delete the rows in the My_Range.Parent worksheet
'rng.EntireRow.Delete
End If
End With
End If
'Close AutoFilter
My_Range.Parent.AutoFilterMode = False
'Restore ScreenUpdating, Calculation, EnableEvents, ....
ActiveWindow.View = ViewMode
Application.Goto DestSh.Range("A1")
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
https://www.rondebruin.nl/win/s3/win006_2.htm
I have tried some of the codes suggested for similar macros.
I need the information in the cells in column L to be individually pasted as pictures in column M. I don't want to manually do this over and over for each of the hundreds of items.
Here is what it looks like without a loop or a repeat. Just doing the operation twice.
Sub pasteaspicture()
pasteaspicture Macro
Range("L3").Select
Selection.Copy
Range("M3").Select
ActiveSheet.Pictures.Paste.Select
Range("L4").Select
Application.CutCopyMode = False
Selection.Copy
Range("M4").Select
ActiveSheet.Pictures.Paste.Select
End Sub
Thanks.
This code should loop from row 3 to end of column L, if that is not what you want then I can edit it for you.
Application.screenupdating = False
With ActiveSheet
LastRow = .Cells(.Rows.Count, "L").End(xlUp).Row
End With
For i = 3 To LastRow
Range("L" & i).Copy
Range("M" & i).Select
ActiveSheet.Pictures.Paste.Select
Next i
Application.screenupdating = true
This code should work, but it includes a select, which is unwanted in VBA but since I have no clue how to use picture paste I used your code as a template.
Here is a quick (but long) way to do it without loops.
It sets ranges and finds the last row of the Column.
You will find Excel has many ways to skin the same nut. Hope this helps.
Sub CopyPic()
Dim lTopRow As Long
Dim lLeftColumn As Long
Dim lRightColumn As Long
Dim lLastRow As Long
With Sheets("Sheet1")
lTopRow = .Range("L3").Row
lLeftColumn = .Range("L3").Column
lLastRow = .Range("L:L").Find("*", , xlValues, , xlByRows, xlPrevious).Row
lRightColumn = lLeftColumn
Application.Goto .Range(Cells(lTopRow, lLeftColumn), Cells(lLastRow, lRightColumn)), scroll:=False
Selection.Copy
lLeftColumn = .Range("M3").Column
lRightColumn = lLeftColumn
Application.Goto .Range(Cells(lTopRow, lLeftColumn), Cells(lLastRow, lRightColumn)), scroll:=False
.Pictures.Paste.Select
End With
End Sub
This code I have cobbled together for collating content from a named worksheet from all open workbooks seems to run fine on my computer, but not on the clients.
Whats going wrong here? I believe we are running the same version of excel, and using identical workbooks to test with.
It gets stuck on line 22:
wkb.Worksheets(sWksName).Copy _
Before:=ThisWorkbook.Sheets(1)
Sorry I don't have the error message!
Sub CopyandCollateQuery1()
With Application ' Scrubs settings that slow process
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Dim wkb As Workbook ' Dim Variables
Dim sWksName As String
Dim Title1 As Range
Dim Title1end As Range
Dim NewRng As Range
Dim check As String
sWksName = "Query1" ' Sets Worksheet to be collated
For Each wkb In Workbooks ' Pulls said worksheet title from each open workbook and copies into macro workbook
If wkb.Name <> ThisWorkbook.Name Then
wkb.Worksheets(sWksName).Copy _
Before:=ThisWorkbook.Sheets(1)
End If
Next
Set wkb = Nothing
For Each ws In ThisWorkbook.Worksheets
With ws
If .Name <> "Collated" Then
rowscount = .Cells(ws.Rows.Count, 2).End(xlUp).Row
.Range("B3" & ":" & "B" & rowscount).Copy
Worksheets("Collated").Activate
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False
End If
End With
Next ws
ActiveSheet.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
If ActiveSheet.Cells(1, 1).Value = "" Then
Rows(1).Delete
ActiveSheet.Cells(1, 2).Value = "Total Combined Count"
End If
ActiveSheet.Cells(1, 1).Activate
For Each ws In ThisWorkbook.Worksheets
With ws
Set lol = ws.Name
If .Name <> "Collated" Then
i = 4
Do While i < rowscount + 1
check = .Range("B" & i).Value
checknum = .Range("B" & i).Offset(0, -1).Value
Sheets("Collated").Activate
Worksheets("Collated").Range("A:A").Find(check, LookAt:=xlWhole).Activate
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = ActiveCell.Value + checknum
checknum = 0
i = i + 1
Loop
End If
End With
Next ws
With Application ' undoes initial processes scrub
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
End Sub
It's also having trouble finding the correct last row when performing the collating action, so I will need to adjust that. But that's beside the point.
As mentioned in your code the For loop For Each wkb In Workbooks is used to Pull said worksheet title from each open workbook and and copy into macro workbook. That means it looks for the sheet Query1 in all the open workbooks and when any of the workbook do not have a sheet named Query1 it throws Subscript out of range error.
You can tackle this error in two ways:
1. Make sure all your workbooks has sheet Query1 (don't think this will always happen)
2. Use error handling in your code
For Each wkb In Workbooks
If wkb.Name <> ThisWorkbook.Name Then
On Error Resume Next '<--- add this line in your code
wkb.Worksheets(sWksName).Copy _
Before:=ThisWorkbook.Sheets(1)
End If
Next
On Error Resume Next resumes execution ignoring any error thrown on the next line of code. Please note that On Error Resume Next does not in any way "fix" the error. It simply instructs VBA to continue as if no error occurred. For details see this link.
Im trying to copy specific rows in a long list containing certain titles onto its own tab.
I had a system that worked using entirerow.copy Destination:= but this was quite untidy and took very long as I had a runclick to work with over 10 modules at once (which had to work with over 3500 rows.
So far I have this but I know the paste part is missing (I'm unsure what to put essentially). This basic format worked very well for me in another macro for formatting cells but obviously it is not quite the same.
Sub Anasuria()
Dim i As Long, LastRow As Long
Dim phrases
Dim rng1 As Range
With Application
.ScreenUpdating = False
.DisplayStatusBar = False
.Calculation = xlCalculationManual
End With
Sheets("Anasuria").Range("A40:AZ10000").ClearContents
phrases = Array("ANASURIA-Central", "ANASURIA-Env. Trading Sys.", "ANASURIA-Fulmar", _
"COOK-Anasuria allocation", "GUILLEMOT-Fulmar Gas")
With Sheets("Main")
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
For i = 40 To LastRow
If Not IsError(Application.match(.Range("A" & i).Value, phrases, 0)) Then
If rng1 Is Nothing Then
Set rng1 = Sheets("Anasuria").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
End If
rng1.PasteSpecial
Next i
End With
With Application
.Calculation = xlCalculationAutomatic
.DisplayStatusBar = True
.ScreenUpdating = True
End With
End Sub
Basically I want the relevant rows to be copied into the "Anasuria" sheet starting at row i.
I have modified your code a little and it should work (just edit range to your needs). One more thing: did you think of using advanced filter? I think it would give you the same results.
Sub Anasuria()
Dim i As Long, LastRow As Long, LastRowAna As Long
Dim phrases
With Application
.ScreenUpdating = False
.DisplayStatusBar = False
.Calculation = xlCalculationManual
End With
Sheets("Anasuria").Range("A1:AZ10").ClearContents
phrases = Array("ANASURIA-Central", "ANASURIA-Env. Trading Sys.", "ANASURIA-Fulmar", _
"COOK-Anasuria allocation", "GUILLEMOT-Fulmar Gas")
LastRow = Sheets("Main").Range("A" & Rows.Count).End(xlUp).Row
LastRowAna = Sheets("Anasuria").Range("A" & Rows.Count).End(xlUp)
For i = 1 To LastRow
If Not IsError(Application.Match(Sheets("Main").Range("A" & i).Value, phrases, 0)) Then
Sheets("Main").Range("A" & i).EntireRow.Copy Sheets("Anasuria").Range("A" & LastRowAna + 1) 'copy/paste part you needed ;)
LastRowAna = LastRowAna + 1
End If
Next i
With Application
.Calculation = xlCalculationAutomatic
.DisplayStatusBar = True
.ScreenUpdating = True
End With
End Sub