I am writing some code for splitting up an excel sheet by a specific column into separate workbooks. My code works but is really slow (It should create 28 separate files and takes around 10 min per file). What can I do to make it perform better? Is there a way to save some calculation time?
Sub Split()
Dim wswb As String
Dim wssh As String
Dim path As String
Worksheets("Sheet1").Activate
wswb = ActiveWorkbook.Name
wssh = ActiveSheet.Name
path = Worksheets("Start").Range("H6").Value
Columns("H").Copy
Worksheets("Settings").Activate
Range("A1").PasteSpecial
Columns("A").RemoveDuplicates Columns:=1, Header:=xlYes
vCounter = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To vCounter
vFilter = Sheets("Settings").Cells(i, 1)
Sheets(wssh).Activate
ActiveWorkbook.Worksheets("Sheet1").AutoFilterMode = False
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=8, Criteria1:=vFilter
Cells.Copy
Workbooks.Add
Range("A1").PasteSpecial
Worksheets("Sheet1").Name = "OTD"
Sheets.Add After:=ActiveSheet
ActiveCell.FormulaR1C1 = ""
Sheets("Sheet2").Select
Sheets("Sheet2").Name = "PPM"
Sheets("OTD").Select
If vFilter <> "" Then
ActiveWorkbook.SaveAs path & "OTD_PPM_Report_" & Format(DateSerial(Year(Date), month(Date) - 1, 1), "mmm_yyyy") & "_" & Range("I2").Value & ".xlsx"
End If
ActiveWorkbook.Close
Workbooks(wswb).Activate
Next i
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=8
End Sub
In general I prefer to use:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
to increase performance every time dealing with excel files. I also use:
Application.Visible = False
which I also believe increase speed.
These are just general remarks.
Ps. Also try to avoid Activate / Select (this may help How to avoid using Select in Excel VBA)
Related
This is what I am working on. I have a workbook that is exporting data, running data through a couple of other macros to sort and format it before inserting the data into a formatted worksheet that will have a "Print to PDF" button. What I am running into is that the print area on this ends up printing hundreds of pages.
My suspicion is that this is happening because I use an excel formula that is modifying the data in every column. The answer MAY be to write this out as VBA code instead of nesting the formulas in the columns. But I think it is counting the cells down through these rows because it has a formula even though the cell itself is blank. Does that make sense? Or can you see any other problems??
Option Explicit
Const EXPORTS As String = "P:\Public\Generated Letters\LTXN Export Spreadsheets\"
Sub Create_PDF()
Dim ws As Worksheet
Dim AccountNumber As String, dt As String, FullName As String, fName As String, sep As String
Dim myrange As String
Set ws = ActiveSheet
AccountNumber = Right(ws.Range("A3").Value, 3) 'not just `A3`
'sets the string end for the print area
myrange = Cells(Rows.Count, 6).End(xlUp).Address
With ActiveSheet.PageSetup
.PrintArea = "A1:" & myrange
.Orientation = xlLandscape
.Zoom = False
.FitToPagesTall = False
.FitToPagesWide = 1
End With
dt = Format(Now, "mm.dd.yyyy hh mm")
fName = EXPORTS & "AccountEnding" & AccountNumber & " - Created On - "
If Len(Dir(fName & ".pdf")) > 0 Then sep = " - "
fName = fName & sep & dt & ".pdf"
ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fName, _
Quality:=xlQualityStandard, IncludeDocProperties:=False, _
IgnorePrintAreas:=False, OpenAfterPublish:=True
Call Shell("explorer.exe" & " " & "P:\Public\Generated Letters\LTXN Export Spreadsheets\", vbNormalFocus)
End Sub
So I found an update as I have been milling around on this, it seems like a copy and insert function is causing the issue here. I have this code run before the print to pdf code:
Sub Data_Filter()
If CountRows = ThisWorkbook.Worksheets("LTXN Data").Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count > 5000 Then
MsgBox ("Due to the number of transactions please reach out to David Wallenburg for assistance.")
Exit Sub
End If
Application.DisplayAlerts = False
Sheets("LTXN Data").Select
Range("A2:I2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("LTXN Formatting").Select
Range("A1:I1").PasteSpecial
Application.CutCopyMode = False
Sheets("LTXN Formatting").Select
Range("M1:R1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Worksheets("LTXN Formatting Sort").Visible = True
Sheets("LTXN Formatting Sort").Select
Range("a1:f1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
Columns("A:F").Sort key1:=Range("E1"), Order1:=xlDescending
Range("A1:F1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Worksheets("LTXN Report").Visible = True
Sheets("LTXN Report").Select
Range("A6:F6").Select
Selection.Insert xlShiftDown
Application.CutCopyMode = False
Dim myrange As String
myrange = Cells(Rows.Count, 6).End(xlUp).Address
Sheets("LTXN Report").Range(Selection, ("a1:" & myrange)).Select
ActiveSheet.Range("A1:" & myrange).BorderAround ColorIndex:=1, Weight:=xlThick
Application.DisplayAlerts = True
Sheets("LTXN Report").Activate
End Sub
I think the problem is that when it goes to the LTXN Formatting Sort page it is selecting much more than the columns with DATA. IS there an easy fix i am missing?
Two ways to go about this then. The first one is to use array formulas, specifically Filter(Range,criteria) and depending on how complicated the data is, you might want to have a separate row to determine what data to include. In my example I'm using:
=COUNTIF(E2:G2,"-/-")<>3
Then I have the "Output Report" section, which can be moved to separate page if need be, by using the formula:
=FILTER(E2:G31,I2:I31)
(to note, I'm using "-/-" instead of "" just to help show the blank spaces.)
You Can now confidently use range("somerange").end(xlup).row to find last row
OR -
If you have no blank rows, you can use
Sheet4.Range("E:E").Find(what:="", LookIn:=xlValues).Row -1
and that will give you the first row without data.
However, if you have some rows that may have nothing in them, you might want to pull the data into an array and step backwards through it to find last row:
Option Explicit
Sub Set_Print_Area()
Dim I
Dim iLow As Long
Dim iHigh As Long
Dim RG
iHigh = Sheet4.Range("E" & Rows.Count).End(xlUp).Row
Set RG = Sheet4.Range("E1:E" & iHigh)
For I = iHigh To 1 Step -1
If RG(I) <> "" Then
Debug.Print I
ActiveSheet.PageSetup.PrintArea = "E1:G" & I
Exit For
End If
Next I
End Sub
Hopefully one of these methods helps.
I have a code (seen below at the bottom of this message) built by someone else and it has worked very well in excel 2010 but our administration migrated us to excel 2019. Now the same code produces errors. I have also tried checking if there were new add-ins or references in the reference library in vba but have not found anything that removes the errors or allows the code to execute properly.
The function of the code is basically like this:
The code is linked to a pivot table in a worksheet in a workbook. It will ask the user a few questions such as is this a 'RFQ' and then a msg box will open for them to enter a file name. It then asks the user if they wish to have the data added to another worksheet in the same workbook. After all these are answered the code should open an new workbook and copy/paste over data from a hidden worksheet from the original workbook into this new workbook. This new workbook should become the focus and allow the user to make any other changes before they save and close it.
The code automatically saved the new workbook in a location (using a HLink) that is referenced from a cell on another hidden worksheet in the original workbook.
The errors that take place now is this: "The following features cannot be saved in macro-free workbooks: VB Project To save a file with these features, click No, and then choose a macro-enabled file type in the File type list. To continue saving as a macro-free workbook, click Yes.
If the user says yes, the it says the new workbook that was just created 'already exists in this location. Do you want to replace it?"
If you say yes, everything goes blank and you have to restart excel. If you say no, the vba debugger opens to the end of the code highlighting the last part of the code:
ActiveWorkbook.SaveAs FileName:=HLink _ , FileFormat:"xlOpenXMLWorkbook, CreateBackup:=False
I have tried changing some sections of the code. From this:
`'Save
On Error GoTo ErrFileClose:
HLink = (FilePath & "\" & FileName & "_" & Format(Date, "[$-409]yyyy-mm-d;#") & ".xlsx")
ActiveWorkbook.SaveAs FileName:=HLink _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End If`
To this:
'Save
On Error GoTo ErrFileClose:
HLink = (FilePath & "\" & FileName & "_" & Format(Date, "[$-409]yyyy-mm-d;#"))
ActiveWorkbook.SaveAs FileName:=HLink _
, FileFormat:=51, CreateBackup:=False
End If
And similarly, from this:
'Check if previously created file is open and close it so new one can be saved
ErrFileClose:
FinalFileName = FileName & "_" & Format(Date, "[$-409]yyyy-mm-d;#") & ".xlsx"
Workbooks(FinalFileName).Close SaveChanges:=True
ActiveWorkbook.SaveAs FileName:=HLink _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
To this:
'Check if previously created file is open and close it so new one can be saved
ErrFileClose:
FinalFileName = FileName & "_" & Format(Date, "[$-409]yyyy-mm-d;#")
Workbooks(FinalFileName).Close SaveChanges:=True
ActiveWorkbook.SaveAs FileName:=HLink _
, FileFormat:=51, CreateBackup:=False
These changes sometimes help and seem to remove the vb project error but it is not consistent every time I run the macro.
Any help is appreciated as we cannot move forward using this as it stands.
Thanks.
Sub ImportFile()
'
' ImportFile Macro
Call UnprotectAll
'Create Import
Dim curWorkbook As Workbook
Dim ReqType As String
Dim FileName As String
Dim FinalFileName As String
Dim FilePath As String
FilePath = Sheets("X").Range("C3").Value
Dim HLink As String
Application.ScreenUpdating = False
Sheets("Import").Visible = True
Sheets("Import").Copy
ActiveSheet.Unprotect
'Edit import to remove formulas and blank rows
Range("A1:AC500").Value = Range("A1:AC500").Value
Columns("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Set curWorkbook = ActiveWorkbook
Windows("Transactions.xlsm").Activate
Sheets("Import").Visible = False
curWorkbook.Activate
'Save Import
ReqType = MsgBox("Click YES if you are creating an RFQ", vbYesNoCancel)
'vbCancel = 2, vbYes = 6, vbNo = 7
If ReqType = 6 Then
ReqType = "RFQ"
Else
If ReqType = 7 Then
ReqType = "Ordered"
Else
Exit Sub
End If
End If
FileName = InputBox("Please enter the Incident number or other Unique ID Number to save this file as:")
'Cancel Save
If FileName = "" Then
ActiveWorkbook.Close SaveChanges:=False
Call ProtectAll
Application.ScreenUpdating = True
MsgBox ("File Not Created")
Exit Sub
Else
'Save
On Error GoTo ErrFileClose:
HLink = (FilePath & "\" & FileName & "_" & Format(Date, "[$-409]yyyy-mm-d;#") & ".xlsx")
ActiveWorkbook.SaveAs FileName:=HLink _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End If
'Add Order to Receive tab ?
If MsgBox("Ok to add this data as Transaction: " & ReqType & "?", vbOKCancel) = vbOK Then
Windows("Transactions.xlsm").Activate
Else
'Do Not add Order to transactions Order - Receipt
ActiveWorkbook.Close SaveChanges:=False
Call ProtectAll
Application.ScreenUpdating = True
MsgBox ("This has not been added as a transaction. Click the HuB button when ready to try again. A new import file will be created and can be saved over the one just created.")
Exit Sub
End If
'AddOrder to Transactions Order - Receipt
ActiveSheet.PivotTables("ToBeOrderedPivot").RowRange.Select
'Remove headers and column 1
Selection.Offset(1, 1).Resize(Selection.Rows.Count - 1, _
Selection.Columns.Count).Select
'Remove Extra Columns
Dim FirstRow As Integer
Dim LastRow As Integer
FirstRow = Selection.Row
LastRow = FirstRow + Selection.Rows.Count - 1
Range("C" & FirstRow & ":F" & LastRow & ",AA" & FirstRow & ":AA" & LastRow & ",L" & FirstRow & ":L" & LastRow).Select
Selection.SpecialCells(xlCellTypeVisible).Copy
'Move to end of Orders table
Sheets("Receive").Select
Count = Range("Orders[Mtl ID]").Rows.Count
Range("B" & Count + 4).Select
'Paste Values
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'Set Values
Selection.Offset(0, 8).Columns(1).Value = Selection.Offset(0, 2).Columns(1).Value
If ReqType = "RFQ" Then
Selection.Offset(0, 2).Columns(1).Value = 0
Selection.Offset(0, 7).Columns(1).Value = ReqType
Else: Selection.Offset(0, 2).Columns(1).Value = Selection.Offset(0, 5).Columns(1).Value
End If
Selection.Offset(0, 5).Columns(1).Value = Selection.Offset(0, 3).Columns(1).Value
Selection.Offset(0, 3).Columns(1).Value = Selection.Offset(0, 4).Columns(1).Value
Selection.Offset(0, 4).Columns(1).Value = Selection.Offset(0, 8).Columns(1).Value
Selection.Offset(0, 8).Columns(1).Value = FileName
Selection.Offset(0, 9).Columns(1).Value = Format(Date, "[$-409]yyyy-mm-d;#")
'Sort Table
Call SortReceive
Call ProtectAll
Application.ScreenUpdating = True
'Return to Import File
curWorkbook.Activate
Exit Sub
'Check if previously created file is open and close it so new one can be saved
ErrFileClose:
FinalFileName = FileName & "_" & Format(Date, "[$-409]yyyy-mm-d;#") & ".xlsx"
Workbooks(FinalFileName).Close SaveChanges:=True
ActiveWorkbook.SaveAs FileName:=HLink _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Resume Next
End Sub
I created a VBA macro that formats and creates charts out of raw data. I have added functionality to track usage of the macro and record usage (username, timestamp, client name) to a .txt file on our database.
The problem I am running into is that I want the usage tracker to be blind to the end user. However, I am getting windows popping up showing a save bar to the directory path. I've tried searching around for a solution to keep this hidden but I am unable to find any code that I'm able to implement to solve.
I expected the following inputs to hide all windows. I am not quite sure if I need more elaborate code to hide the save window.
Application.DisplayAlerts = False
Application.DisplayStatusBar = False
Application.ScreenUpdating = False
Application.EnableEvents = False�
Here is the code Im using to save usage:
'Usage Tracker'
On Error Resume Next
Dim wb As Workbook: Set wb = ActiveWorkbook
''''tracking file location
Dim strFilename As String: strFilename = "\\Ant\dept\CorporateDevelopment\BizDev\In-Shipment\ISO\zz_File_Location\macrotracking.txt"
Dim recordFile As Workbook
Set recordFile = Workbooks.Open(Filename:=strFilename)
Dim LastRow As Long
LastRow = recordFile.Sheets("macrotracking").Range("A1").SpecialCells(xlCellTypeLastCell).Row
wb.Activate
For i = 1 To Worksheets.Count
If Worksheets(i).Name = "Performance" Then
exists = True
End If
Next i
If exists Then
Advertiser_Name = Sheets("Performance").Range("C3").Value
Else
Advertiser_Name = Sheets("Raw Data").Range("J2").Value
End If
MsgBox wb.Name & exists & Advertiser_Name
''''''these are the variables you want to track, just separate by '& ; &'
recordFile.Sheets("macrotracking").Range("A" & LastRow + 1).Value = Environ("USERNAME") & ";" & Format(Now(), "m/dd/yyyy") & ";" & Format(Now(), "hh:nn:ss") & ";" & ActiveSheet.Range("C3").Value & ";" & "TOTAL"
recordFile.Sheets("macrotracking").Range("A" & LastRow + 1).TextToColumns Destination:=Range("A" & LastRow + 1), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, Semicolon:=True
recordFile.Save
recordFile.Close savechanges:=True
If Err <> 0 Then
Err.Clear
End If
On Error GoTo 0
'End Tracker'
I would greatly appreciate it if someone can help me learn how to hide all windows for this entire macro.
I've written a macro from parent file to change a child file.
The parent file has 10 + rows I want to cycle through.
The child file looks at row1 and creates a file based on the name in row 1.
I am then using a For and Next function to get the child to look at the next row and save the file based on the new name etc etc.
I get an error of:
Next without For
My code:
Sub CreateModels()
' set parameters
Dim vDestPath As String
Dim vDestFile As String
Dim vSrcePath As String
Dim vCurrFile As String
Dim vSrceFile As String
Dim vTot As Integer
vSrceFile = "Bridge 3-S Financial Model.xlsx"
vSrcePath = ActiveWorkbook.Path + "\Bridge 3-S Financial Model.xlsx"
vCurrFile = ActiveWorkbook.Name
vDestPath = ActiveWorkbook.Path & "\Output Models\"
'OpenFinancialModel
Workbooks.Open vSrcePath, UpdateLinks:=False
Sheets("Input Sheet Data").Select
Range("A4").Select
'creating models
For vTot = 6 To 1000
ActiveCell.FormulaR1C1 = "='[Input Sheet.xlsm]Input Sheet'!R" & vTot & "C1"
If Range("A4").Value <> 0 Then
Do
filepath = vDestPath & Range("a4") & ".Xlsx"
ActiveWorkbook.SaveAs (filepath)
vTot = vTot + 1
Next
Else
ActiveWorkbook.Close SaveChanges:=False
End If
End Sub
Remove the "Do" keyword and you might want to end the If statement before the "Next" keyword. Something like this:
For vtot = 6 To 1000
ActiveCell.FormulaR1C1 = "='[Input Sheet.xlsm]Input Sheet'!R" & vtot & "C1"
If Range("A4").Value <> 0 Then
filepath = vDestPath & Range("a4") & ".Xlsx"
ActiveWorkbook.SaveAs (filepath)
vtot = vtot + 1
Else
ActiveWorkbook.Close SaveChanges:=False
End If
Next
You need to improve your loops and queries. Half of the query If .. Then .. Else is within a For.. Next - not a good idea. Please check the position of Next and move to another place for your needs.
And there is an aborted Do missing some pseudo code like:
Dim k As Long
Do While k <= 10
Cells(k, 1).Value = k
Loop
Remove Do and debug your code.
I have a macro code to open several excel sheets one after the other (I only show 3 here):
Sub Macro1()
Workbooks.Open Filename:=Range("F19").Value, UpdateLinks:=0
ActiveWindow.Visible = True
Windows("Data Quality Checks - ITS v2.8.xlsm").Activate
Workbooks.Open Filename:=Range("F21").Value, UpdateLinks:=0
ActiveWindow.Visible = True
Windows("Data Quality Checks - ITS v2.8.xlsm").Activate
Workbooks.Open Filename:=Range("F23").Value, UpdateLinks:=0
ActiveWindow.Visible = True
Windows("Data Quality Checks - ITS v2.8.xlsm").Activate
End Sub
The 'Range' shows the cell with the specific file path.
Currently, if the macro does not find one of the files, it produces an error and the process is forced to stop. Is it possible to include an additional line code that if the file is not found in the specified path, then the process continues and does not stop (no debugging)?
This may helps:
Option Explicit
Sub Macro1()
Dim LastRow As Long, i As Long
Dim PathName As String, MissingFiles As String
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 19 To LastRow Step 2 '<- Start from 19 like the example and stop lastrow column A sheet 1. Loop every two.
PathName = .Range("A" & i).Value
If Len(Dir(PathName)) = 0 Then '<- Make sure you add the extension of the file.
If MissingFiles = "" Then
MissingFiles = PathName
Else
MissingFiles = MissingFiles & vbNewLine & PathName
End If
Else
Workbooks.Open Filename:=PathName, UpdateLinks:=0
ActiveWindow.Visible = True
' Windows("Data Quality Checks - ITS v2.8.xlsm").Activate
End If
Next i
MsgBox "Missing Files are: " & vbNewLine & MissingFiles
End With
End Sub
Sheet Structure:
Message Box :