VBA Displaying Cell Reference and Table Range - excel

So i have this userform that allows the user to key in the number of creditors and the number of rows for the table, then after the user clicks confirm, it will generate based on the input values
And now I need this details like which cell contains creditor name 1 and which range is creditor name 1 table like this picture below:
My current code is
'Clears Sheet then generates Number of Creditors & Rows
Worksheets("Payable Conf - by Invoice").Cells.Clear
Dim CreditorsCount As Integer
Dim Counter As Integer
Dim Rows As Integer
If TextBox1.Text <> "" And TextBox2.Text <> "" Then
CreditorsCount = TextBox1.Value
Counter = 0
CreditorsCount2 = 0
Rows = TextBox2.Value
End If
Worksheets("Payable Conf - by Invoice").Activate
While Counter < CreditorsCount
Cells((Counter * (5 + Rows) + 1), 1).Activate
With Range(ActiveCell.Address, ActiveCell.Offset(0, 4))
.Value = Array("Creditor Name " & CStr(Counter + 1), "Creditor Address 1", "Creditor Address 2", "Creditor Address 3", "Staff Email (e.g. abc123#gmail.com)")
.Font.Bold = True
End With
With Range(ActiveCell.Offset(3, 0), ActiveCell.Offset(3, 2))
.Value = Array("Invoice No.", "Invoice Date", "Amount (e.g. $100)")
.Font.Bold = True
End With
With Union(Range(ActiveCell.Address, ActiveCell.Offset(1, 4)), Range(ActiveCell.Offset(3, 0), ActiveCell.Offset(3 + Rows, 2)))
.BorderAround XlLineStyle.xlContinuous, xlThin
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
End With
Counter = Counter + 1
Wend
Worksheets("Payable Conf - by Invoice").Range("I8") = "Please do not edit"
Worksheets("Payable Conf - by Invoice").Range("I9") = "Number of Creditors:"
Worksheets("Payable Conf - by Invoice").Range("J9") = TextBox1.Value
Worksheets("Payable Conf - by Invoice").Range("I10") = "Number of Rows:"
Worksheets("Payable Conf - by Invoice").Range("J10") = TextBox2.Value
Help is greatly appreciated :)

Maybe something like this ?
Sub test()
Dim rg1 As Range
Dim rg2 As Range
Dim cnt As Integer
Dim TotRow As Integer
Dim tbl As Range
cnt = 5
TotRow = 10
With Sheets("Payable Conf - by Invoice")
'.Activate
.Cells.Delete
Set rg1 = .Range("A1")
Set rg2 = .Range("i8")
End With
With rg2
.Resize(3, 1).Value = Application.Transpose(Array("do not edit", "num cred", "num rows"))
.Offset(1, 1).Value = cnt
.Offset(2, 1).Value = TotRow
Set rg2 = rg2.Offset(4, 0)
End With
For i = 1 To cnt
With rg1.Resize(1, 5)
.Value = Array("cr name " & CStr(i), "add1", "add2", "add3", "email")
.Font.Bold = True
.Resize(2, 5).Borders.LineStyle = xlContinuous
End With
Set rg1 = rg1.Offset(3, 0)
With rg1.Resize(1, 3)
.Value = Array("Inv No", "Inv Date", "Inv Amount")
.Font.Bold = True
Set tbl = .Resize(TotRow + 1, 3)
tbl.Borders.LineStyle = xlContinuous
End With
With rg2
.Offset(0, 0).Value = "cred name " & CStr(i) & ":"
.Offset(0, 1).Value = rg1.Offset(-2, 0).Address(0, 0)
.Offset(1, 0).Value = "tbl " & CStr(i) & ":"
.Offset(1, 1).Value = tbl.Address(0, 0)
End With
Set rg1 = rg1.Offset(TotRow + 2, 0)
Set rg2 = rg2.Offset(3, 0)
Next i
End Sub
Please try to run the sub on a new workbook.
If the result is the one that you expected, just change the cnt variable value and the TotRow variable value to your TextBox1.value and TextBox2.value

Related

How can I edit/update an existing record in my database using a listbox in Excel userform?

I am creating an Excel userform in which users can add, search, and update records. I was able to create a button command that searches the database (a single sheet in my workbook) and populates a listbox with the search results. Because my database has more than 10 columns which I wanted to be visible in the listbox, I used an array to populate the listbox rather than AddItem which limited me to 10 or fewer columns. (the search code is below)
Private Sub Search_Click()
''''''''''''Validation
If Trim(SearchTextBox.Value) = "" And Me.Visible Then
MsgBox "Please enter a search value.", vbCritical, "Error"
Exit Sub
End If
ReDim arrs(0 To 17, 1 To 1)
With Worksheets("Sheet1")
ListBox.Clear
ListBox.ColumnCount = 18
ListBox.ColumnHeads = True
ListBox.Font.Size = 10
ListBox.ColumnWidths = "80,80,150,130,90,90,80,80,80,80,80,60,70,150,150,150,150,180"
If .FilterMode Then .ShowAllData
Set k = .Range("K2:K" & Cells(Rows.Count, "K").End(xlUp).Row).Find(What:="*" & SearchTextBox.Text & "*", LookIn:=xlValues, lookat:=xlWhole)
If Not k Is Nothing Then
adrs = k.Address
Do
M = M + 1
ReDim Preserve arrs(0 To 17, 1 To M)
For j = 0 To 17
arrs(j, M) = .Cells(k.Row, j + 1).Value
Next j
Set k = .Range("K2:K" & Cells(Rows.Count, "K").End(xlUp).Row).FindNext(k)
Loop While Not k Is Nothing And k.Address <> adrs
ListBox.Column = arrs
Else
' If you get here, no matches were found
MsgBox "No matches were found based on the search criteria.", vbInformation
End If
End With
End Sub
I also added code so that when I double click on a record in the listbox, it populates the corresponding textbox in the userform.
Private Sub ListBox_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
TextBox1.Text = ListBox.Column(0)
If TextBox1.Text = ListBox.Column(0) Then
TextBox1.Text = ListBox.Column(0)
TextBox2.Text = ListBox.Column(1)
TextBox3.Text = ListBox.Column(2)
TextBox4.Text = ListBox.Column(3)
TextBox5.Text = ListBox.Column(4)
TextBox6.Text = ListBox.Column(5)
TextBox7.Text = ListBox.Column(6)
TextBox8.Text = ListBox.Column(7)
TextBox9.Text = ListBox.Column(8)
TextBox10.Text = ListBox.Column(9)
TextBox11.Text = ListBox.Column(10)
TextBox12.Text = ListBox.Column(11)
TextBox13.Text = ListBox.Column(12)
TextBox14.Text = ListBox.Column(13)
TextBox15.Text = ListBox.Column(14)
TextBox16.Text = ListBox.Column(15)
TextBox17.Text = ListBox.Column(16)
TextBox18.Text = ListBox.Column(17)
End If
End Sub
After double clicking on a search result from the listbox, I want users to be able to edit any information in those textboxes and click a command button to update that entry/record in the database itself. However, I am having some problems with creating this function. I used the following code, and although it doesn't return an error message, it doesn't change the entry in the database.
Dim X As Long
Dim Y As Long
X = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For Y = 2 To X
If Sheets("Sheet1").Cells(Y, 11).Value = SearchTextBox.Text Then
Sheets("Sheet1").Cells(Y, 1).Value = TextBox1
Sheets("Sheet1").Cells(Y, 2).Value = TextBox2
Sheets("Sheet1").Cells(Y, 3).Value = TextBox3
Sheets("Sheet1").Cells(Y, 4).Value = TextBox4
Sheets("Sheet1").Cells(Y, 5).Value = TextBox5
Sheets("Sheet1").Cells(Y, 6).Value = TextBox6
Sheets("Sheet1").Cells(Y, 7).Value = TextBox7
Sheets("Sheet1").Cells(Y, 8).Value = TextBox8
Sheets("Sheet1").Cells(Y, 9).Value = TextBox9
Sheets("Sheet1").Cells(Y, 10).Value = TextBox10
Sheets("Sheet1").Cells(Y, 11).Value = TextBox11
Sheets("Sheet1").Cells(Y, 12).Value = TextBox12
Sheets("Sheet1").Cells(Y, 13).Value = TextBox13
Sheets("Sheet1").Cells(Y, 14).Value = TextBox14
Sheets("Sheet1").Cells(Y, 15).Value = TextBox15
Sheets("Sheet1").Cells(Y, 16).Value = TextBox16
Sheets("Sheet1").Cells(Y, 17).Value = TextBox17
Sheets("Sheet1").Cells(Y, 18).Value = TextBox18
End If
Next Y
Additionally, the term that I am searching with is not unique, so there are multiple records/rows in the database with the same search term. How can I create this code in a way that I when I click on the update button, information from the userform (which has been populated by doubleclicking the record in the listbox) is updated in the excel sheet but not for all records with the same search term?
Thank you so much for any help!
Add a Label to your UserForm to hold the row number from where the text box values came. Use the first column (width zero so hidden) of the listbox to hold the row number of the filtered rows. Set the label to column 0 of the double clicked row.
Option Explicit
Private Sub Update_Click()
Dim r As Long, n As Long
' record showing
r = Val(Label1.Caption)
If r < 1 Then
Exit Sub
End If
With Sheets("Sheet1")
For n = 1 To 18
.Cells(r, n).Value2 = Me.Controls("TextBox" & n)
Next
End With
End Sub
Private Sub ListBox_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim n As Long
With ListBox
For n = 1 To ListBox.ColumnCount - 1
Debug.Print n, .Column(n)
Me.Controls("TextBox" & n).Text = .Column(n)
Next
Label1.Caption = .Column(0)
End With
End Sub
Private Sub Search_Click()
Const COLS = 18
Dim s
s = Trim(SearchTextBox.Value)
If s = "" And Me.Visible Then
MsgBox "Please enter a search value.", vbCritical, "Error"
Exit Sub
Else
s = "*" & s & "*"
End If
Dim rngFnd As Range, rngSearch As Range, first As String
Dim arr, lastrow As Long, i As Long, j As Long
' search sheet
With Worksheets("Sheet1")
If .FilterMode Then .ShowAllData
lastrow = .Cells(.Rows.Count, "K").End(xlUp).Row
Set rngSearch = .Range("K1:K" & lastrow)
i = WorksheetFunction.CountIf(rngSearch, s)
If i > 0 Then
ReDim arr(0 To COLS, 1 To i)
Set rngFnd = rngSearch.Find(What:=s, LookIn:=xlValues, lookat:=xlWhole)
If Not rngFnd Is Nothing Then
i = 0
first = rngFnd.Address
Do
i = i + 1
arr(0, i) = rngFnd.Row
For j = 1 To COLS
arr(j, i) = .Cells(rngFnd.Row, j).Value
Next j
Set rngFnd = rngSearch.FindNext(rngFnd)
Loop While rngFnd.Address <> first
End If
Else
'If you get here, no matches were found
MsgBox "No matches were found based on the search criteria. " & s, vbExclamation
Exit Sub
End If
End With
' format listbox
With ListBox
.Clear
.ColumnCount = COLS + 1
.ColumnHeads = True
.Font.Size = 10
.ColumnWidths = "0,80,80,150,130,90,90,80,80,80,80,80,60,70,150,150,150,150,180"
.Column = arr
End With
End Sub

Issue with part of my code - used to build table

I have a code which builds a table based on the data in another sheet. In this sheet there are three columns - Time, URN and Location. Time is shown as HH:MM:SS, URN is a 4 digit number and Location is a postcode displayed in the usual format.
I have normally used this code with a Date instead of time, but I have been trying to use it with time. I have made a slight adjustment after declaring the date as a variable, adding in the time value part.
I am now getting a
Run-time error '91': Object variable or With block variable not set,
with the following highlighted:
.Cells(FndDt.Row, FndNum.Column) = "P"
I have tried removing this piece of code and adding in a On Error Resume Next but I then get an error on the lines above or below it.
Option Explicit
Sub chrisellis250()
Dim Dt, Urn, i As Long, x As Long, lr As Long, lc As Long: x = 2
Dim colwidth As Long
Dim FndDt As Range, FndNum As Range, Dat As Date, Num As String, Loc As String
Dat = TimeValue("00:00:00")
Application.ScreenUpdating = False
With Sheet2
lr = .Cells(.Rows.Count, 2).End(xlUp).Row
.Range(.Cells(2, 1), .Cells(.Rows.Count, 1)).AdvancedFilter xlFilterCopy, , .Range("E1"), True
With .Range("E1").CurrentRegion: Dt = .Value: End With
Sheet1.Range("A3").Resize(UBound(Dt) - 1) = .Range("E2:E" & UBound(Dt)).Value: .Columns(5).Clear
Sheet1.Range("A3").Resize(UBound(Dt) - 1).Interior.ColorIndex = 15
.Range(.Cells(2, 2), .Cells(.Rows.Count, 2)).AdvancedFilter xlFilterCopy, , .Range("E1"), True
With .Range("E1").CurrentRegion: Urn = .Value: End With
For i = 1 To 2
Sheet1.Cells(2, x).Resize(, UBound(Urn) - 1) = Application.WorksheetFunction.Transpose(.Range("E2:E" & UBound(Urn)).Value)
If i = 1 Then colwidth = 8.3 Else colwidth = 55
Sheet1.Cells(2, x).Resize(, UBound(Urn) - 1).ColumnWidth = colwidth
If x = 2 Then Sheet1.Cells(1, x) = "URN" Else Sheet1.Cells(1, x) = "XXXXX"
Sheet1.Cells(1, x).Resize(, UBound(Urn) - 1).MergeCells = True
Sheet1.Cells(1, x).Resize(, UBound(Urn) - 1).Interior.ColorIndex = 15
x = x + UBound(Urn) - 1
Next i
.Columns(5).Clear
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
If .Range("B" & i) <> "" Then
Dat = .Range("A" & i): Num = .Range("B" & i): Loc = .Range("C" & i)
With Sheet1
.Range("B3").Resize(lr, UBound(Urn) - 1).Font.Name = "Wingdings 2"
lc = .Cells(2, .Columns.Count).End(xlToLeft).Column
Set FndDt = .Range("A:A").Find(Dat, LookIn:=xlValues, lookat:=xlWhole)
Set FndNum = .Range(.Cells(2, 1), .Cells(2, lc)).Find(Num, LookIn:=xlValues, lookat:=xlWhole)
.Cells(FndDt.Row, FndNum.Column) = "P": .Cells(FndDt.Row, FndNum.Column).Font.Color = vbGreen
On Error Resume Next
If Not .Cells(FndDt.Row, FndNum.Column + UBound(Urn) - 1) Like "*" & Loc & "*" Then
.Cells(FndDt.Row, FndNum.Column + UBound(Urn) - 1) = IIf(.Cells(FndDt.Row, FndNum.Column + UBound(Urn) - 1) = "", Loc, .Cells(FndDt.Row, FndNum.Column + UBound(Urn) - 1) & "," & Loc)
End If
End With
End If
Next i
With Sheet1
With .Range("B3").Resize(UBound(Dt) - 1, UBound(Urn) - 1)
.SpecialCells(xlCellTypeBlanks).Font.Color = vbRed: .SpecialCells(xlCellTypeBlanks).Value = "O":
End With
With .Range("B3").Offset(, UBound(Urn) - 1).Resize(UBound(Urn) - 1, UBound(Urn) - 1)
.SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 15
End With
AddOutsideBorders .Range("A1").Resize(UBound(Dt) + 1, 1 + ((UBound(Urn) - 1) * 2))
With .Cells
.Columns.AutoFit
.HorizontalAlignment = xlCenter
.RowHeight = 25
End With
End With
End With
Application.ScreenUpdating = True
End Sub
Public Function AddOutsideBorders(rng As Range)
With rng.Borders
.LineStyle = xlContinuous
.Color = vbBlack
.Weight = xlThin
End With
End Function

Userform to search for two criteria, then paste row's data to userform textboxes

I am getting a run-time error '13': type mismatch for one of the lines marked below. I want to be able to have a userform that you can type two criteria into, then it will search for the row that has both of those criteria and paste the corresponding cells' values to the 11 userform textboxes. I'm not sure why it is giving me an error for this line, or if there is a better way to do this.
Private Sub CommandButton1_Click()
txt1.Visible = True
txt2.Visible = True
txt3.Visible = True
txt4.Visible = True
txt5.Visible = True
txt6.Visible = True
txt7.Visible = True
txt8.Visible = True
txt9.Visible = True
txt10.Visible = True
txt11.Visible = True
Dim ws As Worksheet
Set ws = Sheets("The Goods")
ws.Activate
Dim SearchSearch As Variant
SearchSearch = txtsearch.Value
Dim SearchName As Variant
SearchName = txtname.Value
If Trim(txtsearch.Value) = "" Then
MsgBox "Search can't be left blank.", vbOKOnly + vbInformation, "Search"
End If
If Trim(txtname.Value) = "" Then
MsgBox "Name can't be left blank.", vbOKOnly + vbInformation, "Name"
End If
Dim FirstAddress As String, cF As Range
With ThisWorkbook.Sheets("The Goods").Range("D:D") 'txtsearch will be in the range D:D
Set cF = .Find(What:=SearchSearch, _
after:=ActiveCell, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False) ' line that is giving me an error
With ThisWorkbook.Sheets("The Goods").Range("B:B") 'txtname will be in the range B:B
Set cF = .Find(What:=SearchName, _
after:=ActiveCell, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
txt1.Value = cF.(0, 5).Value
txt2.Value = cF(0, 3).Value
txt3.Value = cF(0, 6).Value
txt4.Value = cF(0, 7).Value
txt5.Value = cF(0, 8).Value
txt6.Value = cF(0, 9).Value
txt7.Value = cF(0, 10).Value
txt8.Value = cF(0, 11).Value
txt9.Value = cF(0, 12).Value
txt10.Value = cF(0, 13).Value
txt11.Value = cF(0, 14).Value
End With
End With
End Sub
Private Sub CommandButton3_Click()
Dim iExit As VbMsgBoxResult
iExit = MsgBox("Are you sure you want to exit?", vbQuestion + vbYesNo, "Search System")
If iExit = vbYes Then
Unload Me
End If
End Sub
The code below is a simple For Loop, which loops through each cel in Column B and checks for txtname.Value, and using offset to check if Column D value is equal to txtsearch.Value. If both match, then it will write the values for that row into the userform text boxes. You can change the TextBox1 to txt1, etc.
Private Sub CommandButton1_Click()
Dim ws As Worksheet, cel As Range
Set ws = Sheets("The Goods")
For Each cel In ws.Cells(2, 2).Resize(ws.Cells(Rows.Count, 2).End(xlUp).Row).Cells
If cel.Value = Me.txtname.Value And cel.Offset(, 2).Value = Me.txtsearch.Value Then
Me.TextBox1.Value = cel.Offset(, 3).Value 'Change to your textbox naming scheme
Me.TextBox2.Value = cel.Offset(, 1).Value
Me.TextBox3.Value = cel.Offset(, 4).Value
Me.TextBox4.Value = cel.Offset(, 5).Value
Me.TextBox5.Value = cel.Offset(, 6).Value
Me.TextBox6.Value = cel.Offset(, 7).Value
Me.TextBox7.Value = cel.Offset(, 8).Value
Me.TextBox8.Value = cel.Offset(, 9).Value
Me.TextBox9.Value = cel.Offset(, 10).Value
Me.TextBox10.Value = cel.Offset(, 11).Value
Me.TextBox11.Value = cel.Offset(, 12).Value
End If
Next cel
End Sub
I would go with something like this:
Private Sub CommandButton1_Click()
Dim i As Long, rngB As Range, n As Long, arrB, arrD
Dim ws As Worksheet
Dim SearchSearch As Variant, SearchName As Variant
For i = 1 To 11
Me.Controls("txt" & i).Visible = True
Next i
Set ws = ThisWorkbook.Sheets("The Goods")
ws.Parent.Activate
ws.Activate
SearchSearch = Trim(txtsearch.Value)
SearchName = Trim(txtname.Value)
'check the trimmed values
If Len(SearchSearch) = 0 Or Len(SearchName) = 0 Then
MsgBox "'Search' and 'Name' can't be left blank.", vbOKOnly + vbInformation, "Search"
Exit Sub
End If
'get search ranges
Set rngB = ws.Range(ws.Range("B1"), ws.Cells(ws.Rows.Count, "B").End(xlUp))
Set rngD = rngB.Offset(0, 2)
'pull the values into a couple of arrays for faster searching
arrB = rngB.Value
arrD = rngD.Value
'loop over the arrays
For n = 1 To UBound(arrB, 1)
If arrB(n, 1) = SearchName And arrD(n, 1) = SearchSearch Then
'got a hit - populate your textboxes
Set cF = rngB.Cells(n, 1)
txt1.Value = cF.Offset(0, 1).Value 'Col C same row
txt2.Value = cF.Offset(0, 2).Value 'Col D same row
txt3.Value = cF.Offset(0, 3).Value 'Col E same row
'etc etc
'OR do something like this:
With rngB.Cells(n, 1).EntireRow
txt1.Value = .Cells(1, "C").Value
txt1.Value = .Cells(1, "D").Value
txt1.Value = .Cells(1, "E").Value
'etc etc
End With
Exit For
End If
Next
If cF Is Nothing Then MsgBox "No match!"
End Sub

How can I speed this vba code up which involves formatting?

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

Copy value of entire row and past it into a different worksheet

I have the following code:
Option Explicit
Dim LastRow As Long
Dim i As Long
Dim myCell2 As Range
Dim oWkSht As Worksheet
Private Sub Worksheet_Activate()
Application.ScreenUpdating = False
'-------------------------------------------
'//Head Row A1\\
'-------------------------------------------
Range("A1").Value = "Department"
Range("B1").Value = "AOS Location"
Range("C1").Value = "Article Number"
Range("D1").Value = "HFB"
Range("E1").Value = "Article Name"
Range("F1").Value = "General Comments"
Range("G1").Value = "Home Location"
Range("H1").Value = "A. Stock"
Range("I1").Value = "SGF"
Range("J1").Value = "Incoming Good"
Range("K1").Value = "M.P.QTY"
Range("L1").Value = "Pallet Qty"
Range("M1").Value = "Start Date"
Range("N1").Value = "AOS SSS"
Range("O1").Value = "End Date"
Range("P1").Value = "End Qty"
Range("Q1").Value = "Promotion week"
Range("R1").Value = "Start-Up Qty"
Range("S1").Value = "Old AWS"
Range("T1").Value = "Goal"
Range("U1").Value = "QTY Sold LW"
Range("V1").Value = "Price"
Range("W1").Value = "GM0"
Range("X1").Value = "Sales Before"
Range("Y1").Value = "Sales this Month"
Range("Z1").Value = "Total Sold this month"
'-----------------------------------------------------------------
'//Date\\
'-----------------------------------------------------------------
Dim FirstDate As Date
Dim LastDate As Date
Dim NextDate As Date
Dim r As Long
Range("AA1").Value = DateSerial(Year(Date), Month(Date), 1)
FirstDate = DateSerial(Year(Date), Month(Date), 1)
LastDate = DateSerial(Year(Date), Month(Date) + 1, 0)
r = 28
Do
FirstDate = FirstDate + 1
Cells(1, r) = FirstDate
r = r + 1
Loop Until FirstDate = LastDate
LastRow = Range("A100000").End(xlUp).Row
Range("Y2").Formula = "=SUM(Registration!AA2:Registration!BE2)"
Range("Y2").Select
Range("Y2:Y" & LastRow).Select
Selection.FillDown
Range("Z2").Formula = "=Registration!Y2*Registration!V2"
Range("Z2").Select
Range("Z2:Z" & LastRow).Select
Selection.FillDown
Selection.NumberFormat = _
"_([$€-x-euro2] * #,##0.00_);_([$€-x-euro2] * (#,##0.00);_([$€-x-euro2] * ""-""??_);_(#_)"
'--------------------------------------------------
'//Format Head, Row A1\\
'--------------------------------------------------
Range("A1", Range("XFD1").End(xlToLeft)).Select
With Selection.Font
.Name = "Calibri"
.FontStyle = "Bold"
.Size = 13
End With
'--------------------------------------------------
'//Select Used rows and column and shift one row down\\
'--------------------------------------------------
Range("A1", Range(Range("A1:A" & LastRow), Range("A1", Range("XFD1").End(xlToLeft)))).Offset(1).Select
With Selection.Font
.Name = "Calibri"
.FontStyle = "Regular"
.Size = 11
End With
'--------------------------------------------------
'//Autofit and Align all cells in rows and columns\\
'--------------------------------------------------
With Cells
.EntireColumn.AutoFit
.EntireRow.AutoFit
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlLeft
End With
'--------------------------------------------------
'//This Code will freeze the first row in the worksheet\\
'--------------------------------------------------
With ActiveWindow
.SplitColumn = 6
.SplitRow = 1
.FreezePanes = True
End With
'--------------------------------------------------
'//This code will delete all of the old products and replace them to the sheet old_products.\\
'--------------------------------------------------
Dim l As Long
Dim dst As Range
Dim sht As Worksheet: Set sht = Worksheets("Old_Products")
With Sheets("Registration")
For l = 2 To LastRow
If .Cells(l, 6).Value = "old product" Then
Set dst = sht.Range("F" & sht.Rows.Count).End(xlUp).Offset(1, -5)
.Cells(l, 6).EntireRow.Copy
dst.PasteSpecial xlPasteValues
.Cells(l, 6).EntireRow.Delete
End If
Next l
End With
'--------------------------------------------------
'//Sorting Column A in Department order\\
'--------------------------------------------------
Dim oRangeSort As Range
Dim oRangeKey As Range
' one range that includes all colums to sort
Set oRangeSort = Range("A1", Range(Range("A1:A" & LastRow), Range("A1", Range("XFD1").End(xlToLeft))))
' start of column with keys to sort
Set oRangeKey = Range("A2")
'//custom sort order\\
Dim sCustomList(1 To 28) As String
sCustomList(1) = "OTW showroom"
sCustomList(2) = "Launch Area"
sCustomList(3) = "Living"
sCustomList(4) = "Media"
sCustomList(5) = "Dining"
sCustomList(6) = "Kitchen"
sCustomList(7) = "Work"
sCustomList(8) = "Sleeping"
sCustomList(9) = "Storage"
sCustomList(10) = "Children"
sCustomList(11) = "Familly"
sCustomList(12) = "Staircase"
sCustomList(13) = "Lift"
sCustomList(14) = "OTW"
sCustomList(15) = "Koken en Eten"
sCustomList(16) = "Textiel"
sCustomList(17) = "Bed"
sCustomList(18) = "Bad"
sCustomList(19) = "Home Organisation"
sCustomList(20) = "Lighting"
sCustomList(21) = "Rugs"
sCustomList(22) = "Wall"
sCustomList(23) = "Home Decoration"
sCustomList(24) = "Self Storage"
sCustomList(25) = "CheckOut"
sCustomList(26) = "Cash Line"
sCustomList(27) = "AS IS"
sCustomList(28) = "SWFOOD"
Application.AddCustomList ListArray:=sCustomList
Sort.SortFields.Clear
oRangeSort.Sort Key1:=Range("A1:A" & LastRow), Order1:=xlAscending, Key2:=Range("B1:B" & LastRow), Order2:=xlAscending, Header:=xlYes, OrderCustom:=Application.CustomListCount + 1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
' clean up
ActiveSheet.Sort.SortFields.Clear
Application.DeleteCustomList Application.CustomListCount
'-------------------------------------------------------
'//This code will compare the sart date for the new product and
'if it's more than one day then it will removes the product from the Registration sheet to the Planned New Products.\\
'-------------------------------------------------------
Dim j As Integer
For j = 2 To LastRow
If Sheets("Registration").Cells(j, "M").Value > Date + 1 Then
Sheets("Registration").Cells(j, "M").EntireRow.Copy Destination:=Sheets("Planned_New_Products").Range("A" & Rows.Count).End(xlUp).Offset(1)
Sheets("Registration").Cells(j, "M").EntireRow.Delete
End If
Next j
''// Stop flickering...
'--------------------------------------------------
Range("A2").Select
Application.ScreenUpdating = True
End Sub
This code copies the entire row based on the inserted text in column F and pastes the row in a different sheet. Now the problem is that I have the following code in column Y
=SUM(Registration!AA2:Registration!BE2) 'the number is from 2 to lastrow
And the following code in column Z
=Registration!Y2*Registration!V2 'the number is from 2 to lastrow
Now my question is how can I only copy the value of this entire row and paste it into a different worksheet?
To copy the entire row of values:
Dim dst As Range
Dim sht As Worksheet: Set sht = Worksheets("Old_Products")
With Sheets("Registration")
For l = lastRow to 2 Step -1
If .Cells(l, 6).Value = "old product" Then
Set dst = sht.Range("F" & sht.Rows.Count).End(xlUp).Offset(1, -5)
.Cells(l, 6).EntireRow.Copy
dst.PasteSpecial xlPasteValues
.Cells(l, 6).EntireRow.Delete
End If
Next l
End With

Resources