I have created a report that copy/paste values from different columns in each row to a new sheet and then saves it as a pdf.
Instead of saving the PDF after each row, I would like to have it loop through all the rows with the same pile number. For example, each pile might have three rows, in which case I want to copy/paste values from the three rows before saving the pdf. Once the unique pile is done, it can continue to save the pdf and then loop to the next pile.
Any suggestions would be greatly appreciated.
Sub ExportingPDF()
'Defining worksheets
Dim detailsSheet As Worksheet
Dim reportSheet As Worksheet
Dim i As Long
Dim LastRow As Long
LastRow = Range("B" & Rows.Count).End(xlUp).Row
'Looping the through each row
For i = 2 To LastRow
Set reportSheet = ActiveWorkbook.Sheets("Contract Form")
Set detailsSheet = ActiveWorkbook.Sheets("New POs")
'Assigning values
SPile = detailsSheet.Cells(i, 2)
SClient = detailsSheet.Cells(i, 1)
SCommodity = detailsSheet.Cells(i, 2)
SOption = detailsSheet.Cells(i, 3)
SQtyMT = detailsSheet.Cells(i, 4)
SPriceMT = detailsSheet.Cells(i, 5)
SWhs = detailsSheet.Cells(i, 6)
SIncoterm = detailsSheet.Cells(i, 8)
SDeliveryCity = detailsSheet.Cells(i, 9)
SPO = detailsSheet.Cells(i, 11)
SDeliveryDate = detailsSheet.Cells(i, 14)
SWhsAddress = detailsSheet.Cells(i, 18)
SClientAddress = detailsSheet.Cells(i, 15)
SClientTownZip = detailsSheet.Cells(i, 16)
'Generating the output
'reportSheet.Cells(19, 1).Value = SPile
'reportSheet.Cells(17, 1).Value = SClient
reportSheet.Cells(17, 1).Value = SCommodity
reportSheet.Cells(17, 5).Value = SOption
reportSheet.Cells(17, 4).Value = SIncoterm
'reportSheet.Cells(1, 1).Value = SWhs
reportSheet.Cells(17, 2).Value = SDeliveryCity
reportSheet.Cells(21, 2).Value = SPriceMT
reportSheet.Cells(17, 6).Value = SPO
reportSheet.Cells(17, 3).Value = SDeliveryDate
'reportSheet.Cells(5, 1).Value = SWhsAddress
reportSheet.Cells(21, 1).Value = SQtyMT
reportSheet.Cells(10, 6).Value = SClient
reportSheet.Cells(11, 6).Value = SClientAddress
reportSheet.Cells(12, 6).Value = SClientTownZip
'Save the PDF file
Worksheets("Contract Form").Range("A1:G28").ExportAsFixedFormat Type:=xlTypePDF,
Filename:= _
Environ("Userprofile") & "\Desktop\" & SPO & ".PDF", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
With ActiveSheet.PageSetup
.Zoom = False
.Orientation = xlPortrait
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Next i
End Sub
Related
Im having a problem where when I am openning up a userform and printing it out as well as printing out an excel sheet is gives me the error
Object error 91
This is the code for the command button that starts loads the Userform and unloads the current userform
Private Sub CommandButton1_Click()
Cells(10, 2).Value = stageBox.Value
Cells(11, 2).Value = materialBox.Value
Cells(12, 2).Value = POBox.Value
Cells(13, 2).Value = MPIBox.Value
Cells(14, 2).Value = LPIBox.Value
Unload Me
UserForm1.Show
End Sub
After it opens it it runs this
Dim Batch As String
Dim Draw As String
Dim Rev As String
Dim ScrapQR As String
Dim goodQty As String
Dim desc As String
Dim scrapQty As String
Dim stage As String
Dim material As String
Dim po As String
Dim mpi As String
Dim lpi As String
Sub UserForm_Initialize()
Call gatherData
Call popData
Call printStuff
Unload Me
End Sub
Sub gatherData()
Batch = Cells(1, 2).Value
Draw = Cells(3, 2).Value
Rev = Cells(4, 2).Value
ScrapQR = Cells(8, 2).Value
goodQty = Cells(6, 2).Value
scrapQty = Cells(7, 2).Value
desc = Cells(2, 2).Value
stage = Cells(10, 2).Value
material = Cells(11, 2).Value
po = Cells(12, 2).Value
mpi = Cells(13, 2).Value
lpi = Cells(14, 2).Value
End Sub
Sub popData()
BatchBox.Text = Batch
DrawBox.Text = Draw
DescBox.Text = desc
RevBox.Text = Rev
GoodBox.Text = goodQty
ScrapBox.Text = scrapQty
DateBox = Date
QRBox.Text = ScrapQR
sBox.Text = Cells(10, 2).Value
matBox.Text = Cells(11, 2).Value
PBox.Text = Cells(12, 2).Value
MBox.Text = Cells(13, 2).Value
LBox.Text = Cells(14, 2).Value
End Sub
Sub printStuff()
Dim fileName As String
fileName = "Surface_Finish_" & Batch
'Print Sheet1 exactly one page wide and tall
With Worksheets("Surface Finish").PageSetup
.Zoom = False
.FitToPagesTall = 1
.FitToPagesWide = 1
End With
Worksheets("Surface Finish").ExportAsFixedFormat _
Type:=xlTypePDF, _
fileName:="N:\Buckets\Sdata\Dyllon_Dunton\" & fileName, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=False, _
IgnorePrintAreas:=False, _
From:=1, _
To:=1, _
OpenAfterPublish:=False
PrintForm
End Sub
Any help would be greatly appreciated
You can not use unload command until you use .show, please remove this one.
Private Sub CommandButton1_Click()
Cells(10, 2).Value = stageBox.Value
Cells(11, 2).Value = materialBox.Value
Cells(12, 2).Value = POBox.Value
Cells(13, 2).Value = MPIBox.Value
Cells(14, 2).Value = LPIBox.Value
Unload Me ' this one..................................
UserForm1.Show
End Sub
I am a complete novice at Excel VBA and I am currently attempting a project on Excel VBA. I have created a UserForm that would allow the user to enter data onto the Excel Sheet by completing the fields in the UserForm. I have tested all the codes individually and they have worked fine.
For the user to access the UserForm, I have added an ActiveX Command Button on a separate sheet on the same workbook. However, when accessing the UserForm from the ActiveX Command Button, some of the codes do not run (mainly the code that flags out the duplicate entry, as well as the code that generates serial numbers).
Where did I go wrong in my code?
This is my code to adding new data as well as the code to flag out duplicate entries. When opening the UserForm from the ActiveX Command Button, adding new data works fine but it does not flag out duplicate entries in the data. (However, testing the code itself in VBA works perfectly fine).
Private Sub cmdAddNewCustomer_Click()
Dim count As Long
Dim lastrow As Long
Dim lCustomerID As String
Dim ws As Worksheet
Set ws = Worksheets("Customer Data")
'find first empty row in database
lrow = ws.Cells.Find(what:="*", searchorder:=xlRows, _
Searchdirection:=xlPrevious, LookIn:=xlValues).Row + 1
lCustomerID = txtCustomerID
count = 0
With ws
For currentrow = 1 To lrow
If lCustomerID = Cells(currentrow, 1) Then
count = count + 1
End If
If count > 1 Then
.Cells(currentrow, 1).Value = ""
.Cells(currentrow, 2).Value = ""
.Cells(currentrow, 3).Value = ""
.Cells(currentrow, 4).Value = ""
.Cells(currentrow, 5).Value = ""
.Cells(currentrow, 6).Value = ""
.Cells(currentrow, 7).Value = ""
.Cells(currentrow, 8).Value = ""
.Cells(currentrow, 9).Value = ""
.Cells(currentrow, 10).Value = ""
.Cells(currentrow, 11).Value = ""
.Cells(currentrow, 12).Value = ""
.Cells(currentrow, 13).Value = ""
.Cells(currentrow, 14).Value = ""
MsgBox ("CustomerID already exists!")
End If
If count = 0 Then
.Cells(lrow, 1).Value = Me.txtCustomerID.Value
.Cells(lrow, 2).Value = Me.txtCustomerName.Value
.Cells(lrow, 3).Value = Me.cboCustomerStatus.Value
.Cells(lrow, 4).Value = Me.txtContactPerson.Value
.Cells(lrow, 5).Value = Me.cboDepartment.Value
.Cells(lrow, 6).Value = Me.txtPosition.Value
.Cells(lrow, 7).Value = Me.cboRoleType.Value
.Cells(lrow, 8).Value = Me.txtofficeHP1.Value
.Cells(lrow, 9).Value = Me.txtOfficeHP2.Value
.Cells(lrow, 10).Value = Me.txtMobileHP1.Value
.Cells(lrow, 11).Value = Me.txtMobileHP2.Value
.Cells(lrow, 12).Value = Me.txtEmail1.Value
.Cells(lrow, 13).Value = Me.txtEmail2.Value
.Cells(lrow, 14).Value = Me.txtEmail3.Value
End If
Next currentrow
End With
'clear the data
Me.txtCustomerName.Value = ""
Me.cboCustomerStatus.Value = ""
Me.txtContactPerson.Value = ""
Me.cboDepartment.Value = ""
Me.txtPosition.Value = ""
Me.cboRoleType.Value = ""
Me.txtofficeHP1.Value = ""
Me.txtOfficeHP2.Value = ""
Me.txtMobileHP1.Value = ""
Me.txtMobileHP2.Value = ""
Me.txtEmail1.Value = ""
Me.txtEmail2.Value = ""
Me.txtEmail3.Value = ""
End Sub
This is the code to generate serial numbers. (Same problem, does not work when accessed via ActiveX Command Button but works fine when tested individually in VBA).
Sub FindCustomerID()
Dim lastrow
Dim lastnum As Long
Dim ws As Worksheet
Set ws = Worksheets("Customer Data")
If Me.cboCountry = "" Or Me.txtCustomerName = "" Then
Exit Sub
End If
serialno = 1
lastrow = ws.Cells(Rows.count, 1).End(xlUp).Row
CountryCode = UCase(Left(Me.cboCountry, 3))
CustomerCode = UCase(Left(Me.txtCustomerName, 10))
'assemble them into CustomerID
CustomerID = CountryCode & CustomerCode & serialno
For currentrow = 2 To lastrow
If CustomerID = Cells(currentrow, 1) Then
'find last number that applies
serialno = serialno + 1
End If
're-assign customerID with new serial number
CustomerID = CountryCode & CustomerCode & serialno
Next currentrow
Me.lblCustomerID = CustomerID
End Sub
And lastly, this is the code from the ActiveX Command Button that brings out the UserForm.
Private Sub cmdNCustomerData_Click()
frmCustomerdata.Show
End Sub
The cause of the problem you described is a missing . to qualify Cells(currentrow, 1). Because you added the ActiveX button to a different sheet, the line
If lCustomerID = Cells(currentrow, 1) Then
accesses Cells(currentrow, 1) of that sheet. To fix this the range needs to be qualified with a . to become
If lCustomerID = .Cells(currentrow, 1) Then
I would also take
If count = 0 Then
.
.
.
End If
outside the loop. You are repeating these lines many times unnecessarily.
The first block of code then becomes:
Private Sub cmdAddNewCustomer_Click()
Dim count As Long
Dim lastrow As Long
Dim lCustomerID As String
Dim ws As Worksheet
Set ws = Worksheets("Customer Data")
'find first empty row in database
lrow = ws.Cells.Find(what:="*", searchorder:=xlRows, _
Searchdirection:=xlPrevious, LookIn:=xlValues).Row + 1
lCustomerID = txtCustomerID
count = 0
With ws
' Count backward to delete rows completely
For currentrow = lrow - 1 To 1 Step -1
If lCustomerID = .Cells(currentrow, 1) Then
count = count + 1
End If
If count > 1 Then
.Cells(currentrow, 1).Resize(1, 14).ClearContents
' Uncomment the following line to delete the whole row completely
'.Rows(currentrow).Delete
End If
Next currentrow
If count > 1 Then
MsgBox (count - 1 " duplicates of CustomerID found and cleared!")
ElseIf count = 0 Then
.Cells(lrow, 1).Value = Me.txtCustomerID.Value
.Cells(lrow, 2).Value = Me.txtCustomerName.Value
.Cells(lrow, 3).Value = Me.cboCustomerStatus.Value
.Cells(lrow, 4).Value = Me.txtContactPerson.Value
.Cells(lrow, 5).Value = Me.cboDepartment.Value
.Cells(lrow, 6).Value = Me.txtPosition.Value
.Cells(lrow, 7).Value = Me.cboRoleType.Value
.Cells(lrow, 8).Value = Me.txtofficeHP1.Value
.Cells(lrow, 9).Value = Me.txtOfficeHP2.Value
.Cells(lrow, 10).Value = Me.txtMobileHP1.Value
.Cells(lrow, 11).Value = Me.txtMobileHP2.Value
.Cells(lrow, 12).Value = Me.txtEmail1.Value
.Cells(lrow, 13).Value = Me.txtEmail2.Value
.Cells(lrow, 14).Value = Me.txtEmail3.Value
End If
End With
'clear the data
Me.txtCustomerName.Value = ""
Me.cboCustomerStatus.Value = ""
Me.txtContactPerson.Value = ""
Me.cboDepartment.Value = ""
Me.txtPosition.Value = ""
Me.cboRoleType.Value = ""
Me.txtofficeHP1.Value = ""
Me.txtOfficeHP2.Value = ""
Me.txtMobileHP1.Value = ""
Me.txtMobileHP2.Value = ""
Me.txtEmail1.Value = ""
Me.txtEmail2.Value = ""
Me.txtEmail3.Value = ""
End Sub
In the FindCustomerID subroutine you have exactly the same problem with the line
If CustomerID = Cells(currentrow, 1) Then
as Cells(currentrow, 1) is not qualified and therefore, should become
If CustomerID = ws.Cells(currentrow, 1) Then
You are also reassigning the CustomerID many times unnecessarily. I would take the reassignment inside the If statement and the loop will become
For currentrow = 2 To lastrow
If CustomerID = ws.Cells(currentrow, 1) Then
'find last number that applies
serialno = serialno + 1
're-assign customerID with new serial number
CustomerID = CountryCode & CustomerCode & serialno
End If
Next currentrow
This way CustomerID is only reassigned if and only if serialno changes.
I have a Sub NewRecord() to create new record and a Sub CB_No_Change() to recall existing record by number to be displayed on the user form. For Sub NewRecord(), I write the code so that some default values are put into the excel sheet in the next empty row then this new record is recalled by Sub CB_No_Change() to be displayed on the user form and can be edited. The Sub CB_No_Change() is working fine on its own, but the Sub NewRecord() usually crashes when being run (the excel application does not respond and automatically reboots). I suspect there may be a loop between this 2 subs? Any ideas?
Private Sub NewRecord()
Dim LastRow As Integer
Dim emptyRow As Integer
LastRow = WorksheetFunction.CountA(Range("$A:$A"))
emptyRow = LastRow + 1
Cells(emptyRow, 1) = "xxx"
Cells(emptyRow, 2) = "xxx"
Cells(emptyRow, 3) = "xxx"
Cells(emptyRow, 4) = "xxx"
Cells(emptyRow, 5) = "xxx"
Cells(emptyRow, 6) = "xxx"
Cells(emptyRow, 7) = "xxx"
Cells(emptyRow, 8) = "xxx"
Cells(emptyRow, 9) = "xxx"
Cells(emptyRow, 10) = "xxx"
Cells(emptyRow, 11) = "xxx"
Cells(emptyRow, 12) = "xxx"
Cells(emptyRow, 13) = "xxx"
Cells(emptyRow, 14) = "xxx"
Cells(emptyRow, 15) = "xxx"
Cells(emptyRow, 16) = "xxx"
Cells(emptyRow, 17) = "xxx"
Me.CB_No = LastRow
Me.TB_RecdDate.SetFocus
End sub
Private Sub CB_No_Change()
Dim FindNo As String
Dim r As Integer
Dim TrgtNo As Range
If Me.CB_No <> "" Then
FindNo = Me.CB_No.Value
Set TrgtNo = Worksheets("One").Range("$A:$A").Find(FindNo, SearchOrder:=xlRows, SearchDirection:=xlPrevious, Lookat:=xlWhole)
If Not TrgtNo Is Nothing Then
r = Worksheets("One").Range("$A:$A").Find(FindNo, SearchOrder:=xlRows, SearchDirection:=xlPrevious, Lookat:=xlWhole).Row
CB = Cells(r, 1)
TB = Cells(r, 2)
Me.TB = Format(Me.TB, "yyyy-mm-dd")
TB = Cells(r, 3)
Me.TB = Format(Me.TB, "yyyy-mm-dd")
TB = Cells(r, 4)
TB = Cells(r, 5)
TB = Cells(r, 6)
TB = Cells(r, 7)
CB = Cells(r, 8)
CB = Cells(r, 9)
CB = Cells(r, 10)
TB = Cells(r, 11)
TB = Cells(r, 12)
TB = Cells(r, 13)
CB = Cells(r, 14)
CB = Cells(r, 15)
CB = Cells(r, 16)
TB = Cells(r, 17)
Else
Exit Sub
End If
Else
Exit Sub
End If
End Sub
Looking at your code, it looks like you are trying to get the row number of the last row in column A, so you can get the row number of the first empty row adding +1 to LastRow.
You are using CountA, a function that just counts non-empty cells in a range.
WorksheetFunction.CountA method (Excel)
This will work only if all your data is continuous. But if your data is like this:
You can see this with an easy code applied to data in the image:
Sub test()
Dim LastRowWithCountA As Long
Dim LastRowNormal As Long
LastRowWithCountA = Application.WorksheetFunction.CountA(Range("A:A"))
LastRowNormal = Range("A" & Rows.Count).End(xlUp).Row
Debug.Print "COUNTA: " & LastRowWithCountA & " VS " & "NORMAL:" & LastRowNormal
End Sub
It will return COUNTA: 15 VS NORMAL:19.
So the best option to get the last non empty row in a column is Range("A" & Rows.Count).End(xlUp).Row
About your error, replaceIntegers with Long. Integers got a lower limit. I recommend you to read all data types admited.
Data type summary
I am setting up a new pricing schedule which reads selected information from a 'Register' tab, based on selected criteria, and copying this into a new tab. This data is formatted so it looks aesthetically pleasing.
I am finding formatting the code is slowing down the run speed significantly. If possible I would like to speed this up as I will be iterating this multiple times.
I hae sped the program up a reasonable amount. Initially it took 30s, whereas now it is about 10s.
I have followed information from this website as best as I can:
https://www.soa.org/News-and-Publications/Newsletters/Compact/2012/january/com-2012-iss42-roper.aspx
I feel there is still scope to improve more, though I am unsure how, and am reaching out to see if there is, or are, better ways to improve the code so it runs quicker.
Option Explicit
Sub create_pricing_schedule()
'define workbook variables
Dim Start_Time As Double, End_Time As Double
Dim file1 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim ws4 As Worksheet
Dim namedRange1 As Range
Dim namedRange2 As Range
Set file1 = ThisWorkbook
Set ws2 = file1.Worksheets("Pricing Schedule")
Set ws3 = file1.Worksheets("Control")
Set ws4 = file1.Worksheets("Register")
Set namedRange1 = file1.Names("Client_Register").RefersToRange
Set namedRange2 = file1.Names("Pricing_Range").RefersToRange
'define general variables
Dim i As Integer
Dim collect(1 To 500, 1 To 10) As Variant
Dim rw As Range
Dim selectedClient As String
Dim lastrow As Integer, lastrow2 As Integer, lastrow3 As Integer
i = 1
'time how long it takes to improve efficiency
Start_Time = Timer
'speedup so less lagg
Call speedup
'delete everything from the pricing schedule/reset
With Sheets("Pricing Schedule")
.UsedRange.ClearContents
.Cells.Interior.ColorIndex = 0
.Cells.Borders.LineStyle = xlNone
.Cells.HorizontalAlignment = xlLeft
.Cells.MergeCells = False
.Range("A:Z").WrapText = False
.Rows.RowHeight = "15"
End With
'resize the client register
lastrow = ws4.Range("A100000").End(xlUp).Row
With ActiveWorkbook.Names("Client_Register")
.RefersTo = "=Register!$A$1:$AE$" & lastrow
End With
selectedClient = ws3.Range("B3").Value
'copy from database to the pricing schedule as a non formatted list of all the info - this runs quickly, but I am open to changing it
For Each rw In Range("Client_Register").Rows
If Range("Client_Register").Cells(rw.Row, 2) = selectedClient Then
collect(i, 1) = Range("Client_Register").Range("E" & rw.Row)
collect(i, 2) = Range("Client_Register").Range("D" & rw.Row)
collect(i, 3) = Range("Client_Register").Range("F" & rw.Row)
collect(i, 4) = Range("Client_Register").Range("J" & rw.Row)
collect(i, 5) = Range("Client_Register").Range("K" & rw.Row)
collect(i, 6) = Range("Client_Register").Range("L" & rw.Row)
collect(i, 7) = Range("Client_Register").Range("M" & rw.Row)
collect(i, 8) = Range("Client_Register").Range("P" & rw.Row)
collect(i, 9) = Range("Client_Register").Range("I" & rw.Row)
collect(i, 10) = Range("Client_Register").Range("H" & rw.Row) ' used to determine if pass through fee
ws2.Range("B" & i + 6) = collect(i, 1)
ws2.Range("C" & i + 6) = collect(i, 2)
ws2.Range("D" & i + 6) = collect(i, 3)
ws2.Range("E" & i + 6) = collect(i, 4)
ws2.Range("F" & i + 6) = collect(i, 5)
ws2.Range("G" & i + 6) = collect(i, 6)
ws2.Range("H" & i + 6) = collect(i, 7)
ws2.Range("I" & i + 6) = collect(i, 8)
ws2.Range("J" & i + 6) = collect(i, 9)
ws2.Range("K" & i + 6) = collect(i, 10)
i = i + 1
End If
Next
'add in the colour and count how many rows there are
lastrow2 = ws2.Range("C5000").End(xlUp).Row
With ActiveWorkbook.Names("Pricing_Range")
.RefersTo = "='Pricing Schedule'!$A$1:$K$" & lastrow2
End With
ws2.Range("B7" & ":" & "J" & lastrow2).Interior.Color = RGB(242, 242, 242)
'==========this bit is slow, can it be quicker?==========
'add spacing, titles, and colour to sub headers
i = 7
For Each rw In Range("Pricing_Range").Rows
If Range("Pricing_Range").Cells(i, 3) <> Range("Pricing_Range").Cells(i + 1, 3) Then
Range("Pricing_Range").Rows(i + 1).Insert Shift:=xlShiftDown
Range("Pricing_Range").Rows(i + 1).Insert Shift:=xlShiftDown
Range("Pricing_Range").Rows(i + 1).Interior.ColorIndex = 0
Range("Pricing_Range").Rows(i + 2).Interior.ColorIndex = 0
Range("Pricing_Range").Range("B" & i + 2 & ":" & "J" & i + 2).Interior.Color = RGB(255, 128, 1)
Range("Pricing_Range").Range("B" & i + 2 & ":" & "J" & i + 2).Borders(xlEdgeTop).Color = RGB(0, 0, 0)
Range("Pricing_Range").Range("B" & i + 2 & ":" & "J" & i + 2).Borders(xlEdgeBottom).Color = RGB(0, 0, 0)
Range("Pricing_Range").Range("B" & i + 2).Value = Range("Pricing_Range").Range("C" & i + 3).Value
'if it is a pass through fee then add it in to the sub headers
If Range("Pricing_Range").Range("K" & i + 3).Value = "Pass-Through" Then
Range("Pricing_Range").Range("J" & i + 2).Value = "Pass-Through Fees"
Range("Pricing_Range").Range("J" & i + 2).HorizontalAlignment = xlRight
End If
i = i + 3
Else
i = i + 1
End If
Next
'==================================================
'set up the main title rows
ws2.Select
Range("Pricing_Range").Range("B2").Value = ws3.Range("B3").Value
Range("Pricing_Range").Range("B2").Font.Size = 20
Range("Pricing_Range").Range("B2").Font.Bold = True
Range("Pricing_Range").Range("B2").Font.FontStyle = "Calibri Light"
Range("Pricing_Range").Range("B2:J3").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.MergeCells = True
.Cells.Interior.Color = RGB(255, 128, 1)
.Cells.Borders(xlEdgeTop).Color = RGB(0, 0, 0)
.Cells.Borders(xlEdgeBottom).Color = RGB(0, 0, 0)
End With
'tidy up things in the sheet
With Worksheets("Pricing Schedule")
'set up the headers and first title
.Range("B6") = .Range("C7")
.Range("B5:J6").Interior.Color = RGB(255, 128, 1)
.Range("B5:J5").Borders(xlEdgeTop).Color = RGB(0, 0, 0)
.Range("B5:J5").Borders(xlEdgeBottom).Color = RGB(0, 0, 0)
.Range("B6:J6").Borders(xlEdgeTop).Color = RGB(0, 0, 0)
.Range("B6:J6").Borders(xlEdgeBottom).Color = RGB(0, 0, 0)
.Range("B5").Value = "Fee Code"
.Range("C5").Value = "Product Line"
.Range("D5").Value = "Item"
.Range("E5").Value = "Volume From"
.Range("F5").Value = "Volume To"
.Range("G5").Value = "Frequency"
.Range("H5").Value = "Location"
.Range("I5").Value = "Price"
.Range("J5").Value = "Nature of Fee"
'tidy up column widths
.Range("A5").RowHeight = 30
.Range("A1").ColumnWidth = 2
.Range("B1").ColumnWidth = 15
.Range("C1").ColumnWidth = 40
.Range("D1").ColumnWidth = 45
.Range("E1").ColumnWidth = 11
.Range("F1").ColumnWidth = 11
.Range("G1").ColumnWidth = 35
.Range("H1").ColumnWidth = 15
.Range("I1").ColumnWidth = 12
.Range("J1").ColumnWidth = 50
.Range("J:J").WrapText = True
.Range("K:K").Delete
End With
'clear the extra orange line at the end
lastrow3 = ws2.Range("B1000").End(xlUp).Row
With ws2.Rows(lastrow3 + 2)
.Cells.Interior.ColorIndex = 0
.Cells.Borders.LineStyle = xlNone
.ClearContents
End With
'add print area
With Worksheets("Pricing Schedule")
.PageSetup.Zoom = False
.PageSetup.Orientation = xlPortrait
.PageSetup.PrintArea = "$B$2:$J$" & lastrow3
.PageSetup.FitToPagesWide = 1
.PageSetup.FitToPagesTall = False
.PageSetup.PrintTitleRows = "$2:$6"
End With
'return to normal
Call slowdown
'time how long it takes to improve efficiency
End_Time = Timer
Worksheets("Control").Cells(6, 2) = End_Time - Start_Time
End Sub
Sub speedup()
Application.Calculation = xlManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayStatusBar = False
End Sub
Sub slowdown()
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayStatusBar = True
End Sub
I found a few lines that could save you some execution time.
'****EDIT****Changed this to direct range reference rather than go through the Names collection.
'Set namedRange1 = file1.Names("Client_Register").RefersToRange
'Set namedRange2 = file1.Names("Pricing_Range").RefersToRange
Set namedRange1 = file1.Range("Client_Register")
Set namedRange2 = file1.Range("Pricing_Range")
Used range takes more time rather use .cells directly
'delete everything from the pricing schedule/reset
'****EDIT***
With ws2 'Sheets("Pricing Schedule")
'used range takes more time rather use .cells directly
.Cells.ClearContents
Rather than use arrays you can directly update values as shown below
'I am using i for the row count
ws2.Range("B" & i + 6).Value = namedRange1.Cells(i, 5).Value
ws2.Range("C" & i + 6).Value = namedRange1.Cells(i, 4).Value
ws2.Range("D" & i + 6).Value = namedRange1.Cells(i, 6).Value
ws2.Range("E" & i + 6).Value = namedRange1.Cells(i, 10).Value
ws2.Range("F" & i + 6).Value = namedRange1.Cells(i, 11).Value
ws2.Range("G" & i + 6).Value = namedRange1.Cells(i, 12).Value
ws2.Range("H" & i + 6).Value = namedRange1.Cells(i, 12).Value
ws2.Range("I" & i + 6).Value = namedRange1.Cells(i, 16).Value
ws2.Range("J" & i + 6).Value = namedRange1.Cells(i, 9).Value
ws2.Range("K" & i + 6).Value = namedRange1.Cells(i, 8).Value
i = i + 1
The main culprit for your slower performance is the insert operation. try to work the logic to not having insert. If not possible, try to insert rows outside the loop in a single operation rather than in the loop
Range("Pricing_Range").Rows(i + 1).Insert Shift:=xlShiftDown
Range("Pricing_Range").Rows(i + 1).Insert Shift:=xlShiftDown
Your handling of the collect array is inefficient. Consider reading the entire Client Register into an array with MyArray = Range.Value. Then prepare the output array in memory and write it to the worksheet after all looping is done, in one go, with TargetRange.Value = collect.
Avoid inserting rows. What's wrong with the existing? If you are preparing all data in an array to be pasted to the worksheet, empty array elements will produce empty worksheet cells. In this way all inserting can be avoided and all you need to do is to format.
There is time cost for every access to the worksheet, whether to read or write. Even for formatting, try to create ranges that are treated in the same manner. Avoid accessing the worksheet in loops.
Example of With and block assignment from an array:
'copy from database to the pricing schedule as a
' non formatted list of all the info - this runs quickly,
' but I am open to changing it
With Range("Client_Register")
For Each rw In .Rows
If .Cells(rw.Row, 2) = selectedClient Then
collect(i, 1) = .Range("E" & rw.Row)
collect(i, 2) = .Range("D" & rw.Row)
collect(i, 3) = .Range("F" & rw.Row)
collect(i, 4) = .Range("J" & rw.Row)
collect(i, 5) = .Range("K" & rw.Row)
collect(i, 6) = .Range("L" & rw.Row)
collect(i, 7) = .Range("M" & rw.Row)
collect(i, 8) = .Range("P" & rw.Row)
collect(i, 9) = .Range("I" & rw.Row)
collect(i, 10) = .Range("H" & rw.Row)
'you could even skip the row-by-row population of values
' and assign as a block after exiting the loop
ws2.Range("B" & i + 6).Resize(1, 10).Value = _
Array(collect(i, 1), collect(i, 2), collect(i, 3), _
collect(i, 4), collect(i, 5), collect(i, 6), _
collect(i, 7), collect(i, 8), collect(i, 9), _
collect(i, 10))
i = i + 1
End If
Next
End With
Note this will break if your Client_Register refers to a range which doesn't start on Row1, because of the relative range references.
Eg:
Range("A1:A10").Range("A1") 'refers to A1
Range("A2:A10").Range("A1") 'refers to A2
I have a workbook with monthly worksheets. One for Emails and one for Calls and I have created two userForms for data entry, one for Emails and one for Calls.
The forms do the job and they enter date in the right place but if I have selected the "August 18 Email" sheet and use the Email form, once the form is submitted it jumps to display the "August 18 Calls" sheet.
I just want it to stay in the selected worksheet, in this case "August 18 Email".
The code for the Emails form is the one below and the one for the Calls is nearly the same but only changing this line : Set ws = Sheets(Format(Date, "mmmm yy") & " calls")
Private Sub CommandButton2_Click()
Dim lRow As Long
Dim ws As Worksheet
Set ws = ActiveSheet
Set ws = Sheets(Format(Date, "mmmm yy") & " emails")
lRow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
With ws
If Me.txtDateBox.Value = "" Then
.Cells(lRow, 1).Value = Format(Date, "dd/mmm/yy")
Else
.Cells(lRow, 1).Value = Me.txtDateBox.Value
End If
myVar = ""
For x = 0 To Me.ListBox2.ListCount - 1
If Me.ListBox2.Selected(x) Then
If myVar = "" Then
myVar = Me.ListBox2.List(x, 0)
Else
myVar = myVar & "," & Me.ListBox2.List(x, 0)
End If
End If
Next x
.Cells(lRow, 11).Value = myVar
myVarSign = ""
For x = 0 To Me.ListBox3.ListCount - 1
If Me.ListBox3.Selected(x) Then
If myVarSign = "" Then
myVarSign = Me.ListBox3.List(x, 0)
Else
myVarSign = myVarSign & "," & Me.ListBox3.List(x, 0)
End If
End If
Next x
.Cells(lRow, 12).Value = myVarSign
myVarTheme = ""
For x = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(x) Then
If myVarTheme = "" Then
myVarTheme = Me.ListBox1.List(x, 0)
Else
myVarTheme = myVarTheme & "," & Me.ListBox1.List(x, 0)
End If
End If
Next x
.Cells(lRow, 14).Value = myVarTheme
.Cells(lRow, 2).Value = Me.Time.Value
.Cells(lRow, 3).Value = Me.ComboBox1.Value
.Cells(lRow, 4).Value = Me.ComboBox2.Value
.Cells(lRow, 5).Value = Me.ComboBox3.Value
.Cells(lRow, 6).Value = Me.ComboBox4.Value
.Cells(lRow, 7).Value = Me.ComboBox5.Value
.Cells(lRow, 8).Value = Me.ComboBox15.Value
.Cells(lRow, 9).Value = Me.ComboBox6.Value
.Cells(lRow, 10).Value = Me.ComboBox7.Value
.Cells(lRow, 13).Value = Me.ComboBox11.Value
.Cells(lRow, 15).Value = Me.ComboBox16.Value
.Cells(lRow, 16).Value = Me.TextBox2.Value
End With
Me.txtDateBox.Value = ""
Me.Time.Value = ""
Me.ComboBox1.Value = ""
Me.ComboBox2.Value = ""
Me.ComboBox3.Value = ""
Me.ComboBox4.Value = ""
Me.ComboBox5.Value = ""
Me.ComboBox6.Value = ""
Me.ComboBox7.Value = ""
Me.ComboBox11.Value = ""
Me.ComboBox16.Value = ""
Me.ComboBox15.Value = ""
Me.TextBox2.Value = ""
Dim iCount As Integer
For iCount = 0 To Me!ListBox1.ListCount
Me!ListBox1.Selected(iCount) = False
Next iCount
For iCount = 0 To Me!ListBox2.ListCount
Me!ListBox2.Selected(iCount) = False
Next iCount
For iCount = 0 To Me!ListBox3.ListCount
Me!ListBox3.Selected(iCount) = False
Next iCount
End Sub
It could be improved a lot but I am happy if after submission the worksheet in view stays instead to jumping to another one.
As you can see I am only beginning (I have managed to create this with help of others).
If you remove any instances of .Select or .Activate on worksheet, range, or cell objects, your sheet shouldn't change.
If that is not an option, another solution would be to note what sheet you are on when the code is called and then Activate that sheet before ending your sub. Since we do not see all of the userform code, you will have to strategically decide where this goes (as mentioned by #K.Davis, nothing shown switches the sheet so it must be happening in some other code).
When the macro/userform is launched:
Dim StartSheet as Worksheet
Set StartSheet = ActiveSheet
Then, before exiting macro/userform:
StartSheet.Activate
You may have to pass this along as a parameter depending on how your code is structured.