I've been building a program to create invoices dependent on the number of clients/owners my company is interacting with. For every one client, we potentially have multiple owners, what we do is create an individual invoice for each owner. My problem is that the code is designed to copy a template sheet and then edit it accordingly, this copying process slows down my code to between 10 and 20 seconds (I have a timer in the code).
Is there any other way I could more efficiently do this? I have an image in the sheet which does not copy over well when I simply try to create a new sheet and then copy/paste from the template sheet. Any other ideas?
Thanks!
Edit:
Private Sub CommandButton1_Click()
Dim t As Single
t = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheets("Client Invoice Template").Visible = True
Sheets("Client Invoice Template").Visible = True
Sheets("Client Invoice Template").Copy Before:=Sheets(3)
Sheets("Client Invoice Template (2)").Name = "Client Invoice"
Sheets("Client Invoice Template").Visible = False
Sheets("Select").Select Application.Calculation = xlCalculationAutomatic
MsgBox Timer - t
End Sub
Based on the method in my comment, I did a test with my own (very simple) template that is shown below for full disclosure:
Method 1 (Your Code)
it took 0.09375 seconds to complete.
EDIT: Method 2 (based on Bruce Wayne's Comment)
it took .015625 seconds to complete! That is 6xs as fast!
Sub CommandButton3_Click()
Dim t As Single
t = Timer
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Dim wsT As Worksheet, ws As Worksheet
Set wsT = Sheets("Client Invoice Template")
wsT.Visible = True 'view template
Set ws = Sheets.Add(Before:=Sheets(3)) 'add new sheet
With wsT
'copy row height and column width
'row height
Dim rng as Range
For each rng in .range("A1:A100")
ws.Rows(rng.Row).RowHeight = rng.Height
Next
'column width
For each rng in .Range("A1:D1")
ws.Columns(rng.Column).ColumnWidth = rng.Width
Next
wsT.Range("A1:D100").Copy 'copy template data (change range accordingly)
With ws
.Range("A1").PasteSpecial xlPasteValues 'past values (change range accordingly)
.Range("A1").PasteSpecial xlPasteFormats 'past formats (change range accordingly)
.Pictures.Insert("C:\Users\Public\Pictures\Sample Pictures\Chrysanthemum.jpg").Select
With .Shapes("Picture 1")
.Top = ws.Range("B2").Top 'adjust as needed
.Left = ws.Range("B2").Left 'adjust as needed
.Height = 126.72 'adjust as needed
.Width = 169.2 'adjust as needed
End With
.Name = "Client Invoice"
End With
wsT.Visible = False
Application.Calculation = xlCalculationAutomatic
Debug.Print Timer - t
End Sub
Method 3 (Based on My Comment)
it took 0.03125 seconds to complete! That is 3Xs as fast!
Code is below:
Sub CommandButton2_Click()
Dim t As Single
t = Timer
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Dim wsT As Worksheet, ws As Worksheet
Set wsT = Sheets("Client Invoice Template")
wsT.Visible = True 'view template
Set ws = Sheets.Add(Before:=Sheets(3)) 'add new sheet
wsT.Range("A1:D100").Copy 'copy template data (change range accordingly)
With ws
.Range("A1").PasteSpecial xlPasteValues 'past values (change range accordingly)
.Range("A1").PasteSpecial xlPasteFormats 'past formats (change range accordingly)
End With
wsT.Shapes("Picture 1").Copy 'change to your picture name accordingly
With ws
.Range("B2").PasteSpecial 'paste to cell (change range accordingly)
.Name = "Client Invoice" 'rename
End With
wsT.Visible = False
Application.Calculation = xlCalculationAutomatic
Debug.Print Timer - t
End Sub
Related
I do a report every day in which I have to copy and paste several sheets into a new workbook titled Report (today's date).
In my report I have 4 sheets : Customers, Orders, Country, ID.
Customer and Country are a simple copy and paste from the master file, but Orders and ID are filtered data from one of my sheets in the master file. Orders is filtered to "Complete" and Id is everything except ID 200 and 500.
I tried building a macro based on this solution found here :
http://www.hivmr.com/db/ack717pc8f88jpdsf7838pcaspkcsdmd
The copy and paste works but I am unable to copy and paste multiple sheets/ rename sheets and filter the data.
Edit:
Sub CopyInNewWB()
'has been tested
Dim newWS, WS As Worksheet
Application.ScreenUpdating = False
Set WS = ThisWorkbook.Sheets("Sheet1")
Set newWS = Workbooks.Add.Sheets("Sheet1")
WS.Cells.Copy
newWS.Cells.PasteSpecial xlValues Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
No clue how your filtered sheets are set up, but this method will copy the sheets in your master exactly how they are currently filtered to a new workbook:
Sub CopyInNewWB()
Dim wbO As Workbook, wbN As Workbook
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Set wbO = ActiveWorkbook
Set wbN = Workbooks.Add
wbO.Sheets("Customers").Copy wbN.Sheets(1)
wbO.Sheets("Orders").Copy wbN.Sheets(2)
wbO.Sheets("Country").Copy wbN.Sheets(3)
wbO.Sheets("ID").Copy wbN.Sheets(4)
wbN.Sheets("Sheet1").Delete
wbN.Sheets("Customers").Activate
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
ErrHandler:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub
I'm writing a macro in VBA for Excel. I want it to replace all worksheets except for a few. First there is a loop which deletes the unwanted sheets, and then comes another one which creates new sheets to repace them! On a first run, the macro removes unwanted sheets. However, if it is run again it seems to be unable to delete the sheets it previously created, which causes a name duplicity error.
(The rng variable is supposed to extend across the entire row but I haven't gotten to fixing that yet.)
Hope you guys can provide some insight, much appreciated!
sub Terminator()
Dim Current As Worksheet
Application.DisplayAlerts = False
' Loop through all of the worksheets in the active workbook.
For Each Current In Worksheets
If Not Current.Name = "Data" Then
Worksheets(Current.Name).Delete
End If
Next Current
Application.DisplayAlerts = True
' Define range for loop
Dim rng As Range, cell As Range
Set rng = Sheets("Data").Range("A5:M5")
' Loop through entire row, looking for employees
For Each cell In rng
If cell.Value = "Nummer" Then
' Make new chart for employee
With Charts.Add
.ChartType = xlLineMarkers
.Name = cell.Offset(-1, 1).Value
.HasTitle = True
.ChartTitle.Text = cell.Offset(-1, 1).Value
' Set data (dynamic) and x-axis (static) for new chart
.SetSourceData Source:=Sheets("Data").Range(cell.Offset(-2, 3), cell.Offset(7, 4))
.Axes(xlValue).MajorGridlines.Select
.FullSeriesCollection(1).XValues = "=Data!E4:E12"
' Add trendlines
.FullSeriesCollection(1).Trendlines.Add Type:=xlLinear, Forward _
:=0, Backward:=0, DisplayEquation:=0, DisplayRSquared:=0, Name:= _
"Trend (DDE)"
.FullSeriesCollection(2).Trendlines.Add Type:=xlLinear, Forward _
:=0, Backward:=0, DisplayEquation:=0, DisplayRSquared:=0, Name:= _
"Trend (SDE)"
End With
' Chart is moved to end of all sheets
Sheets(cell.Offset(-1, 1).Value).Move _
after:=Sheets(Sheets.Count)
End If
Next cell
End Sub
No need to define the worksheet with the Worksheets()
Sub Terminator()
Dim Current As Worksheet
Application.DisplayAlerts = False
' Loop through all of the worksheets in the active workbook.
For Each Current In ActiveWorkbook.Worksheets
If Not Current.Name = "Data" Then
Current.Delete
End If
Next Current
Application.DisplayAlerts = True
End sub
The Following code (minor changes worked in my workbook), are you sure you have the names you put in the If in your Workbook ?
Anyway, I think it's better to use Select for multiple possible mathces
Sub Terminator()
Dim Current As Excel.Worksheet
Application.DisplayAlerts = False
' Loop through all of the worksheets in the active workbook.
For Each Current In ActiveWorkbook.Sheets
If Not (Current.Name = "Data") Then
ActiveWorkbook.Worksheets(Current.Name).Delete
End If
Next Current
Application.DisplayAlerts = True
End Sub
Solution to the deletion is supplied by RGA, but in case you want to avoid several AND statements for each sheet that you want to retain, you can utilize a function similar to the isInArray below:
Sub Terminator()
Dim Current As Variant
Application.DisplayAlerts = False
' Loop through all of the worksheets in the active workbook.
For Each Current In ThisWorkbook.Sheets
If Not isInArray(Current.Name, Array("Data")) Then
Current.Delete
End If
Next
Application.DisplayAlerts = True
End Sub
Function isInArray(theValue As String, vArr As Variant) As Boolean
Dim vVal As Variant
isInArray = False
For Each vVal In vArr
If LCase(vVal) = LCase(theValue) Then
isInArray = True
End If
Next
End Function
EDIT:
function that takes a worksheet name as argument, and returns a worksheet object of that name. If the name is allready taken, the existing sheet is deleted and a new one created:
'example of use:
'set newWorksheet = doExist("This new Sheet")
Function doExist(strSheetName) As Worksheet
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsTest As Worksheet
Dim nWs As Worksheet
Set wsTest = Nothing
On Error Resume Next
'Set wsTest = wb.Worksheets(strSheetName) 'commented out in Edit of Edit
Set wsTest = wb.Sheets(strSheetName) 'as a comment for one of the other threads reveal, the error could be the deletion of Worksheets, which would be a subgroup to Sheets of which graph sheets are no a part
On Error GoTo 0
If Not wsTest Is Nothing Then
Application.DisplayAlerts = False
wsTest.Delete
Application.DisplayAlerts = True
End If
'Set doExist = wb.Worksheets.Add(after:=wb.Sheets(wb.Sheets.Count)) 'Edit of Edit, the later call to Charts.Add does this for you
'doExist.Name = strSheetName 'Edit of Edit, no need to return anything
End Function
I did a program in VBA to copy the formulas in each cell in a specific column, I have 30501 points and the program is really slow even to calculate 100 points, there is a better way to do so?
Sub Copyformulas()
Dim i As Integer
Dim cell As Range
Dim referenceRange As Range
Dim a As String
a = "$T$30510"
Set range1= ActiveSheet.Range("A1:A30510")
Set myrange = Range("T16:T30510")
i = 16
Do Until Cells(20, 30510)
With range1
For Each cell In myrange
If cell.HasFormula Then
Cells(i, 35).Value = cell.Address
Cells(i, 36).Value = "'" & CStr(cell.Formula)
i = i + 1
End If
Next
End With
Loop
End Sub
You can use SpecialCells to refine your range. You don't need to use ActiveSheet it is implied.
Set rSource = Range("A16:A30510").SpecialCells(xlCellTypeFormulas)
Sub Copyformulas()
Application.Calculation = xlManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim c As Range
Dim rSource As Range
Set rSource = ActiveSheet.Range("A16:A30510").SpecialCells(xlCellTypeFormulas)
For Each c In rSource
c.Offset(0, 34) = c.Address
c.Offset(0, 35) = "'" & c.Formula
Next
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Try adding the following:
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
... Your Code ...
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
You may only need the first one, but they are all good practice in using. Also, where are you using the With ... End With statement? I don't see any use of it in the block.
It is good practice to use Option Explicit at the top of the module. And range1 and myrange are not declared.
Application.Calculation
When a worksheet is accessed or a range's precedents has changed, Excel will automatically recalculate the formulas on the worksheet. Since you are looping over 30,000 times, this causes Excel to recalculate each time through the loop and, thus, slows down performance.
Application.ScreenUpdating
This line stops Excel from screen flashes and other things that occur as the macro runs.
Application.EnableEvents
This line turns off events, such as Worksheet_Change, so that the event is not triggered. If it is not turned off then any time a change occurs on the worksheet the code in the change event will run. If you have a Worksheet_SelectionChange event then code will run every time you select a different cell. These events are written in the worksheet or workbook objects located in the project window of the VBE and there are many events to choose from. Here is a very simple illustration. Place the following in the Sheet1 object in the project window:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
MsgBox "Hi!"
End Sub
Now click around on the worksheet. You see it responds to each selection change. Now place the following in a regular module:
Sub TestEnableEvents()
Application.EnableEvents = False
ActiveCell.Offset(1, 0).Select
Application.EnableEvents = True
End Sub
When you run the above code the message box will not be triggered.
I want to copy data from each tab in a spreadsheet and save it as new workbooks. The original workbook has many tabs (approx 50) and one of these tabs set up for the macro to run data from, as there may be new tabs added in the future. The macro data tab contains the file location for each new workbook, the name of the tab and also some information used by another macro to e-mail these newly created workbooks to relevant parties.
The issue is getting the macro to recognize the tab names for finding the range to copy, as the tab names are listed in a cell. I am unsure if it is possible to use this list, or whether I add a sheet at the end to loop through all the sheets from a specified start location until that one with an if.
Sub Datacopy()
Dim ws As Worksheet
With Application
.ScreenUpdating = False
End With
Application.DisplayAlerts = False
Set ws = Sheets("email")
For Each Cell In ws.Columns("B").Cells
Dim file1 As String
file1 = Cell.Offset(0, 3).Text
Sheets("cell.value").Range("A1:L500").Copy
Workbooks.Add.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteAllUsingSourceTheme)
Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteComments)
ActiveWorkbook.SaveAs Filename:=file1
ActiveWorkbook.Close
Next Cell
Application.DisplayAlerts = True
With Application
.ScreenUpdating = True
End With
MsgBox ("Finished making files!")
End Sub
Something like this should work for you. Note the following:
Code assumes that on sheet "email" it has a header row which is row 1 and the actual data starts on row 2.
It checks to see if the B column cell is a valid worksheet name in the workbook
I have verified that this code works properly and as intended based on your original post:
Sub Datacopy()
Dim wb As Workbook
Dim wsData As Worksheet
Dim wsTemp As Worksheet
Dim rSheetNames As Range
Dim rSheet As Range
Set wb = ActiveWorkbook
Set wsData = wb.Sheets("email")
Set rSheetNames = wsData.Range("B2", wsData.Cells(Rows.Count, "B").End(xlUp))
If rSheetNames.Row < 2 Then Exit Sub 'No data
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
For Each rSheet In rSheetNames
If Not Evaluate("ISERROR('" & rSheet.Text & "'!A1)") Then
Set wsTemp = Sheets.Add
Sheets(rSheet.Text).Range("A1:L500").Copy
wsTemp.Range("A1").PasteSpecial xlPasteAllUsingSourceTheme
wsTemp.Range("A1").PasteSpecial xlPasteComments
wsTemp.Move
ActiveWorkbook.SaveAs rSheet.Offset(, 3).Text
ActiveWorkbook.Close False
End If
Next rSheet
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
MsgBox "Finished making files!"
End Sub
I am trying to loop through some columns in a row and create new worksheets with the name of the value of the current column/row that I am in.
Sub test()
Range("R5").Select
Do Until IsEmpty(ActiveCell)
Sheets.Add.Name = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
Loop
End Sub
This code creates the first one correctly starting at R5 but then it appears that the macro switches to that worksheet and doesn't complete the task.
The Sheets.Add automatically moves your selection to the newly created sheet (just like if you insert a new sheet by hand). In consequence the Offset is based on cell A1 of the new sheet which now has become your selection - you select an empty cell (as the sheet is empty) and the loop terminates.
Sub test()
Dim MyNames As Range, MyNewSheet As Range
Set MyNames = Range("R5").CurrentRegion ' load contigeous range into variable
For Each MyNewSheet In MyNames.Cells ' loop through cell children of range variable
Sheets.Add.Name = MyNewSheet.Value
Next MyNewSheet
MyNames.Worksheet.Select ' move selection to original sheet
End Sub
This will work better .... you assign the list of names to an object variable of type Range and work this off in a For Each loop. After you finish you put your Selection back to where you came from.
Sheets.Add will automatically make your new sheet the active sheet. Your best bet is to declare variables to your objects (this is always best practice) and reference them. See like I've done below:
Sub test()
Dim wks As Worksheet
Set wks = Sheets("sheet1")
With wks
Dim rng As Range
Set rng = .Range("R5")
Do Until IsEmpty(rng)
Sheets.Add.Name = rng.Value
Set rng = rng.Offset(0, 1)
Loop
End With
End Sub
Error handling should always be used when naming sheets from a list to handle
invalid characters in sheet names
sheet names that are too long
duplicate sheet names
Pls change Sheets("Title") to match the sheet name (or position) of your title sheet
The code below uses a variant array rather than a range for the sheet name for performance reasons, although turning off ScreenUpdating is likely to make the biggest difference to the user
Sub SheetAdd()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim strError As String
Dim vArr()
Dim lngCnt As Long
Dim lngCalc As Long
Set ws1 = Sheets("Title")
vArr = ws1.Range(ws1.[r5], ws1.[r5].End(xltoRight))
If UBound(vArr) = Rows.Count - 5 Then
MsgBox "sheet range for titles appears to be empty"
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
End With
For lngCnt = 1 To UBound(vArr)
Set ws2 = Sheets.Add
On Error Resume Next
ws2.Name = vArr(lngCnt, 1)
If Err.Number <> 0 Then strError = strError & vArr(lngCnt, 1) & vbNewLine
On Error GoTo 0
Next lngCnt
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
End With
If Len(strError) > 0 Then MsgBox strError, vbCritical, "These potential sheet names were invalid"
End Sub
This is probably the simplest. No error-handling, just a one-time code to create sheets
Sub test()
Workbooks("Book1").Sheets("Sheet1").Range("A1").Activate
Do Until IsEmpty(ActiveCell)
Sheets.Add.Name = ActiveCell.Value
Workbooks("Book1").Sheets("Sheet1").Select
ActiveCell.Offset(0, 1).Select
Loop
End Sub