Auto-Filtering A Dynamic Table and Copy-Pasting to Word Template
Hello All,
I'm trying to tweek the code I have below (I've tried to annotate as best I can) to accommodate an upcoming project request in which I need to populate a table in a Word doc. template with updated customer pricing for the specific models the customer purchases.
The data I've received is similarly structured to the table below, where some customers purchase multiple models (i.e. some customers purchase 4 models, some purchase 2 while others purchase upwards of 50).
|
|
|
|
|
|
|
| $ 8,000.00 |
| $ 500.00 |
| $ 2,100.00 |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
| $ 5,000.00 |
| $ 102,000.00 |
| $ 89.00 |
|
What I need my code to do is auto filter by customer number (a unique identifier) then copy and paste the resulting excel table into my word template.
The code below works well for a limited number of customers/models where I find and replace specific variables (customer name, address, date etc.) then populate my word template table at the bottom of my document with the relevant model, description and price. However, it does not scale well with large data sets (upwards of 500 customers each of whom could potentially be purchasing 100 different models).
While the code below will work, in I'm looking to increase efficiency by adding in the auto-filter, creating the table, then copy pasting the table into my Word template instead.
With that in mind, a) what is the best method to achieve this in terms of efficiency and b) assuming this is an efficient method, where in the code below does the auto-filter line of code need to be inserted? Additionally, the pricing data will be housed on a separate tab (pricing) within my workbook while customer information (address, zip etc while be on its own tab).
Sub CreateContracts()
'Disable screenupdating and alerts
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'path and file name variables
Dim TemplateFilePath As String
Dim TemplateFileName As String
Dim SaveAsFileName As String
Dim savePath As String
Dim AccountRegion As String
Dim strReply As String
Dim startRow As Integer
Dim lastRow As Integer
'sheet variables
Dim PricingSh As Worksheet
Dim tempSH As Worksheet
Dim sH As Worksheet
Dim localCustomer As Boolean
'variables for Excel ranges and for each loops
Dim varColRange As Range
Dim varCell As Range
Dim lastCol As Integer
Dim custRange As Range
Dim custCell As Range
Dim modelCell As Range
'Word variables for tables and Ranges
Dim tblModel As Word.Table
Dim tblAddress As Word.Table
Dim tblRow As Word.Row
Dim wrdDoc As Document
Dim wrdApp As Word.Application
Dim oSection As Word.Section
Dim oRange As Word.Range
Dim varCount As Integer
'set up the object variable for referring to sheet1 through out the code
Set sH = Sheet1
Set PricingSh = Sheet5
Set tempSH = Sheet3
'ensure user id set up
userID = Environ("Username")
'determine start row (found by where customer number is)
startRow = Application.Match("*customer*number*", PricingSh.Columns(1), 0)
'if the first customer name row is blank, then notify the user
If PricingSh.Cells(startRow + 1, 2).Value2 = "" Then
'if blank, then the first row does not have a customer number
MsgBox "No customers entered"
'go to the last lines of code to reset the settings, titled as "Cancel Out"
Exit Sub
End If
'determine lastrow by NAME and not SOLD TO NUMBER because we might have Group entities without a number
lastRow = PricingSh.Cells(startRow, 2).End(xlDown).Row
'first column
lastCol = PricingSh.Cells(startRow, 1).End(xlToRight).Column
'set up the variable column range to loop through
Set varColRange = PricingSh.Range(PricingSh.Cells(startRow, 1), PricingSh.Cells(startRow, lastCol))
'set up the customer range to loop through
Set custRange = PricingSh.Range(PricingSh.Cells(startRow + 1, 1), PricingSh.Cells(lastRow, 1))
'provide quick check to see if user wants to proceed with creating contracts
strReply = MsgBox("Are you ready to create your PALs?", vbYesNo, "Create Contracts")
If strReply = vbNo Then GoTo CancelOut
'save path to the Strategic Pricing folder (specifically, subfolders)
savePath = "\\usaupfil03\depts$\Contracts\Strategic Pricing\Auto Quote Generators\Universal PAL Generator\PALs"
'determine contract type from looking up what the user selected in the Contract Type combobox with the "WordTemps" Table on the Template Reference sheet
TemplateFileName = sH.Range("TemplateFilename").Value
TemplateFilePath = "\\usaupfil03\depts$\Contracts\Strategic Pricing\Auto Quote Generators\Universal PAL Generator"
'Assign Word Objects, which opens the app
Set wrdApp = New Word.Application
'hide Word document when editing
'wrdApp.Visible = False
'wrdApp.ScreenUpdating = False
'loop through each customer row
For Each custCell In custRange
'show the updating form to ensure the user that the app is not hanging during the check...
With UpdateForm
.StartUpPosition = 0
.Left = Application.Left + (0.5 * Application.Width - 0.5 * .Width)
.Top = Application.Top + (0.5 * Application.Height - 0.5 * .Height)
.UpdateLabel.Caption = "Writing the " & custCell.Offset(, 1).Value2 & " file..."
.Show
.Repaint
End With
'determine if a local or group entity
If custCell.Value2 <> "" Then
'label as a local
localCustomer = True
'set up the save file name for a Sold To Number
SaveAsFileName = custCell.Offset(, 1).Value2 & "-" & custCell.Value2 & "-" & sH.Range("ProductName").Value & "-" & "_" & Format(Date, "DDMMMYYYY")
' ''OPTIONAL feature to enable here''
' 'determine the region per the customer number (optional because regions need to be updated)
' AccountRegion = determineAccountRegion(custCell.Value2)
Else
'label as a group entity
localCustomer = False
'set up the save file name for a Group Entity without a number in the filename
SaveAsFileName = custCell.Offset(, 1).Value2 & "-" & sH.Range("ProductName").Value & "-" & "_" & Format(Date, "DDMMMYYYY")
End If
'open word doc template
Set wrdDoc = wrdApp.Documents.Open(Filename:=TemplateFilePath & TemplateFileName, ReadOnly:=True)
'Save the Word document as a separate file
wrdDoc.SaveAs2 Filename:=savePath & SaveAsFileName & ".docx" _
, FileFormat:=wdFormatXMLDocument, LockComments:=False, _
Password:="", AddToRecentFiles:=True, WritePassword:="", _
ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False, CompatibilityMode:=14
'loop through each column to grab the variables and the values
For Each varCell In varColRange
'check if the column header has a "variable" title, if not, then skip find/replacing the value
If InStr(1, varCell.Value2, "var", vbTextCompare) > 0 And PricingSh.Cells(custCell.Row, varCell.Column).Value2 <> 0 _
And PricingSh.Cells(custCell.Row, varCell.Column).Value2 <> "" Then
'Cycle through Find/Replace of Word Template with the customer info and headers
With wrdApp.Selection.Find
.Text = varCell.Value2 'variable to lookup in the Word template from the column header
.Highlight = True 'if this is enabled if will only find/replace hightlighted items
.Replacement.Text = PricingSh.Cells(custCell.Row, varCell.Column).Text 'value to replace with
.Replacement.Highlight = False 'this removes the highlighting in the Word template
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
wrdApp.Selection.Find.Execute Replace:=wdReplaceAll 'perform the find/replace
End If
Next varCell
'find/replace with the model numbers and descriptions
For Each modelCell In sH.ListObjects("ModelTbl").ListColumns(1).DataBodyRange
'if the model number is not blank in the table then start the find/replace
If modelCell.Value2 <> "" Then
'Model Number - Find/Replace
With wrdApp.Selection.Find
.Text = modelCell.Offset(, 3).Value2 'variable to lookup in the Word template from the column header
.Highlight = True 'if this is enabled if will only find/replace hightlighted items
.Replacement.Text = modelCell.Text 'value to replace with
.Replacement.Highlight = False 'this removes the highlighting in the Word template
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
wrdApp.Selection.Find.Execute Replace:=wdReplaceAll 'perform the find/replace
'Model Number - Find/Replace
With wrdApp.Selection.Find
.Text = modelCell.Offset(, 4).Value2 'variable to lookup in the Word template from the column header
.Highlight = True 'if this is enabled if will only find/replace hightlighted items
.Replacement.Text = modelCell.Offset(, 1).Text 'value to replace with
.Replacement.Highlight = False 'this removes the highlighting in the Word template
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
wrdApp.Selection.Find.Execute Replace:=wdReplaceAll 'perform the find/replace
End If
Next modelCell
'find/replace with contract analyst/creator name and date
'loop through Word Sections 1 to 3 of the footers to replace with the values
For Each oSection In wrdDoc.Sections()
For varCount = 1 To 3
'assign the Word Range to the Footers
Set oRange = oSection.Footers(varCount).Range
'set up the Find function parameters
With oRange.Find
.Text = "[varFILN]" 'variable to lookup in the Word template from the column header
.Highlight = True 'if this is enabled if will only find/replace hightlighted items
.Replacement.Text = userID 'value to replace with
.Replacement.Highlight = False 'this removes the highlighting in the Word template
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
'execute the find function
oRange.Find.Execute Replace:=wdReplaceAll
'set up the Find function parameters
With oRange.Find
.Text = "[varCustomerName]" 'variable to lookup in the Word template from the column header
.Highlight = True 'if this is enabled if will only find/replace hightlighted items
.Replacement.Text = custCell.Offset(, 1).Value 'value to replace with
.Replacement.Highlight = False 'this removes the highlighting in the Word template
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
'execute the find function
oRange.Find.Execute Replace:=wdReplaceAll
Next varCount
Next oSection
'clear the variable no longer needed
Set oRange = Nothing
'loop through and replace for option variables in the template provided 0 = empty, so > 0 and we have values
If WorksheetFunction.CountA(Sheet1.ListObjects("tblOther").DataBodyRange) > 0 Then
'find/replace with the model numbers and descriptions
For Each modelCell In sH.ListObjects("tblOther").ListColumns(1).DataBodyRange
'if the model number is not blank in the table then start the find/replace
If modelCell.Value2 <> "" Then
'Model Number - Find/Replace
With wrdApp.Selection.Find
.Text = modelCell.Value2 'variable to lookup in the Word template from the column header
.Highlight = True 'if this is enabled if will only find/replace hightlighted items
.Replacement.Text = modelCell.Offset(, 1).Text 'value to replace with
.Replacement.Highlight = False 'this removes the highlighting in the Word template
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
'execute the find/replace
wrdApp.Selection.Find.Execute Replace:=wdReplaceAll
End If
Next modelCell
End If
'set up (instantiate) the word tables in the template
Set tblAddress = wrdDoc.Tables(1)
Set tblModel = wrdDoc.Tables(2)
'delete unecessary rows of the table that are not used for the address, e.g., a group entity
For Each tblRow In tblAddress.Rows
If InStr(1, tblRow.Range.Text, "var", vbTextCompare) > 0 Then
tblRow.Delete
End If
Next tblRow
'delete unecessary rows of the table that are not used for models
For Each tblRow In tblModel.Rows
If InStr(1, tblRow.Range.Text, "var", vbTextCompare) > 0 Then
tblRow.Delete
End If
Next tblRow
'saving as a pdf....disabling for now
wrdDoc.ExportAsFixedFormat OutputFileName:= _
savePath & SaveAsFileName & ".pdf" _
, ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
'slight pause for saving delay
Application.Wait (Now + TimeValue("0:00:01"))
'close the word doc file prior to the next one
wrdDoc.Save
wrdDoc.Saved = True 'prevents save pop-up dialogue prior to close
wrdDoc.Close
'loop to next customer
Next custCell
'check if we need to close Word (if other documents open by user, don't close it)
If wrdApp.Documents.Count = 0 Then
'close the app if not other documents are open
wrdApp.Quit
Else
'ensure the app is visible for the user
wrdApp.Visible = True
wrdApp.ScreenUpdating = True
wrdApp.ScreenRefresh
End If
'saving as a pdf....disabling for now
'wrdDoc.ExportAsFixedFormat OutputFileName:= _
savePath & SaveAsFileName & ".pdf" _
, ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
'focus back on the Excel file
ThisWorkbook.Activate
Sheet1.Activate
'Turn back on Excel settings and exit this function (macro)
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.DisplayAlerts = True
'notify the user
'show the updating form to ensure the user that the app is not hanging during the check...
With UpdateForm
.StartUpPosition = 0
.Left = Application.Left + (0.5 * Application.Width - 0.5 * .Width)
.Top = Application.Top + (0.5 * Application.Height - 0.5 * .Height)
.UpdateLabel.Caption = "Contract successfully created and saved to the Strategic Pricing network folder."
.Show
.Repaint
End With
'brief pause so user can see message
Application.Wait (Now + TimeValue("0:00:02"))
'remove the form
Unload UpdateForm
'clear out the memory for the Word object variables
Set wrdDoc = Nothing
Set wrdApp = Nothing
Exit Sub
'code is used for resetting the settings if the user cancels after being asked to proceed
CancelOut:
'Turn back on Excel settings and exit this function (macro)
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
Public Function UpdateCustomerInfo()
Dim rst As ADODB.Recordset
Dim cnt As ADODB.Connection
Dim custFile As String
Dim SQLstring As String
Dim i As Integer
Dim dataSH As Worksheet
'assign an object variable
Set dataSH = Sheet4
'show the updating form to ensure the user that the app is not hanging during the 5-10 second update
With UpdateForm
.StartUpPosition = 0
.Left = Application.Left + (0.5 * Application.Width - 0.5 * .Width)
.Top = Application.Top + (0.5 * Application.Height - 0.5 * .Height)
.UpdateLabel.Caption = "Customer information is greater than 1 week old." & vbCrLf & vbCrLf & "Updating the customer database. Please wait..."
.Show
.Repaint
End With
'file location
custFile = "\\ussppiis12\Contracts\All_Customers_Info_and_Salesorg_2yrs.xlsx"
'\\usaupfil01\depts$\Contracts\Development\CContracts
'sql string to retrieve customer data
'Note: "#"s are required to replace periods if periods "." exist in the table's headers
SQLstring = "SELECT DISTINCT [Sold To Customer Number], [Sold To Customer Name], [Sold To Customer - City], " & _
"[Sold To Customer - State Abbreviation], [Sold To Customer - Zip], [Sold To Customer - Address 1], " & _
"[Sold To Customer Number Customer Classific# (Name)] FROM [Report 1$]" & _
" WHERE LEFT([Sold To Customer Number], 1) = '1';"
'Saving Sales region in case needed later
'[Sales Region - Short Name]
'create new ADODB objects
Set cnt = New ADODB.Connection
Set rst = New ADODB.Recordset
'open an connection
With cnt
.Provider = "Microsoft.ACE.OLEDB.12.0;Data Source=" & custFile & ";Extended Properties='Excel 12.0;HDR=Yes;IMEX=1';"
.Open
End With
'open the recordset using the SQL string
With rst
.Open SQLstring, cnt, adOpenForwardOnly, adLockReadOnly, adCmdText
End With
With UpdateForm
.UpdateLabel.Caption = "Customer update succesful."
.Repaint
End With
'clear old data
dataSH.UsedRange.Clear
'copy field headers
For i = 1 To rst.Fields.Count
'copy field headers to first row
dataSH.Cells(1, i).Value = rst.Fields(i - 1).Name
Next
'paste the results to public sheet 2 variable
dataSH.Range("A2").CopyFromRecordset rst
Application.Wait (Now + TimeValue("0:00:01"))
'remove the form from memory
Unload UpdateForm
'close the connections and set the object variables to nothing
rst.Close
cnt.Close
Set rst = Nothing
Set cnt = Nothing
'convert text version of customer numbers to numbers
dataSH.Columns(1).TextToColumns
'update the cell with today's date so data is not always updated unecessarily every Monday
'Note: When this file is opened, it checks to see if it's Monday, and runs this update, however, we don't want to keep doing this on Monday
dataSH.Range("A1").End(xlToRight).Offset(, 1).Value = Date
End Function
Sub callCustomerInfo()
Dim startRow As Integer
Dim sH As Worksheet
'set up the pricing sheet variable
Set sH = Sheet5
'determine the starting row number by looking for the customer number field header
startRow = Application.Match("*customer*number*", sH.Columns(1), 0)
'if the first customer number row is not blank, then call the function to look up the customer information by the customer number
If sH.Cells(startRow + 1, 1).Value2 <> "" Then
'call the public function to look up the customer information
Call populateCustomerInfo
Else
'if blank, then the first row does not have a customer number
MsgBox "No customer numbers entered"
End If
End Sub
Public Function populateCustomerInfo()
Dim lastRow As Long
Dim sH As Worksheet
Dim ShInfo As Worksheet
Dim i As Long
Dim CustInfoRowNumber As Long
Dim startRow As Integer
Dim startCol As Integer
Dim lastCustInfoCol As Integer
Dim AddressColInfo As Integer
Dim NameColInfo As Integer
Dim NumberColInfo As Integer
Dim CityColInfo As Integer
Dim StateColInfo As Integer
Dim ZipColInfo As Integer
Dim classColInfo As Integer
Dim AddressColPrice As Integer
Dim NameColPrice As Integer
Dim NumberColPrice As Integer
Dim CityColPrice As Integer
Dim StateColPrice As Integer
Dim ZipColPrice As Integer
Dim classColPrice As Integer
Dim contactColPrice As Integer
'set up the object variable for the sheet were we input price and fill in customer number
Set sH = Sheet5
'the sheet with the customer information for lookup
Set ShInfo = Sheet4
'start Column
startCol = 1
'startRow
startRow = Application.Match("*customer*number*", sH.Columns(startCol), 0)
'determine the last entered/pasted row
lastRow = sH.UsedRange.SpecialCells(xlCellTypeLastCell).Row
'determine the last customer information column
lastCustInfoCol = Application.Match("*model*", sH.Rows(startRow), 0)
'set up dynamic variables to handle column (header) changes in the Pricing setup input page
AddressColPrice = Application.Match("*street*", sH.Rows(startRow), 0)
NameColPrice = Application.Match("*name*", sH.Rows(startRow), 0)
NumberColPrice = Application.Match("*customer*number*", sH.Rows(startRow), 0)
CityColPrice = Application.Match("*city*", sH.Rows(startRow), 0)
StateColPrice = Application.Match("*state*", sH.Rows(startRow), 0)
ZipColPrice = Application.Match("*zip*", sH.Rows(startRow), 0)
classColPrice = Application.Match("*facility*", sH.Rows(startRow), 0)
contactColPrice = Application.Match("*contact*", sH.Rows(startRow), 0)
'set up dynamic variables to handle column (header) changes in the Customer Information database
AddressColInfo = Application.Match("*address*", ShInfo.Rows(1), 0)
NameColInfo = Application.Match("*name*", ShInfo.Rows(1), 0)
NumberColInfo = Application.Match("*customer*number*", ShInfo.Rows(1), 0)
CityColInfo = Application.Match("*city*", ShInfo.Rows(1), 0)
StateColInfo = Application.Match("*state*", ShInfo.Rows(1), 0)
ZipColInfo = Application.Match("*zip*", ShInfo.Rows(1), 0)
classColInfo = Application.Match("*classific*", ShInfo.Rows(1), 0)
'check if another row besides 1 exists
If lastRow <> 1 Then
'turn off events temporarily while we update other cells (this is necessary because when we update the cells with the customer information _
they'll be flagged as a trigger event to check if something has changed
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'clear out the old information
sH.Range(sH.Cells(startRow + 1, startCol + 1), sH.Cells(lastRow, lastCustInfoCol - 1)).Clear
'start the loop
For i = startRow + 1 To lastRow
If IsError(Application.Match(sH.Cells(i, 1), ShInfo.Columns(1), 0)) = False Then
CustInfoRowNumber = Application.Match(sH.Cells(i, 1), ShInfo.Columns(1), 0)
'name
sH.Cells(i, NameColPrice).Value2 = ShInfo.Cells(CustInfoRowNumber, NameColInfo).Value2
'address
sH.Cells(i, AddressColPrice).Value2 = ShInfo.Cells(CustInfoRowNumber, AddressColInfo).Value2
'city
sH.Cells(i, CityColPrice).Value2 = ShInfo.Cells(CustInfoRowNumber, CityColInfo).Value2
'state
sH.Cells(i, StateColPrice).Value2 = ShInfo.Cells(CustInfoRowNumber, StateColInfo).Value2
'zip
sH.Cells(i, ZipColPrice).Value2 = ShInfo.Cells(CustInfoRowNumber, ZipColInfo).Value2
'facility type
sH.Cells(i, classColPrice).Value2 = ShInfo.Cells(CustInfoRowNumber, classColInfo).Value2
'Contact name, "Director of Purcasing"
sH.Cells(i, contactColPrice).Value2 = "Valued Customer"
ElseIf sH.Cells(i, 1).Text <> "" Then
'notify user nothing found
sH.Cells(i, NameColPrice).Value2 = "No results found..."
End If
Next
'turn back on watching the worksheet for user changes
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End If
'also autofit the columns
sH.Columns.AutoFit
'resize to help with view and button visibility
If sH.Columns(2).ColumnWidth < 30 Then
'ideal size if the the autofit made the column too small
sH.Columns(2).ColumnWidth = 30
End If
End Function
Sub resetModels()
Dim sH As Worksheet
Dim mainPage As Worksheet
Dim startRow As Integer
Dim startCol As Integer
Dim tbl As ListObject
Dim i As Integer
Dim counter As Integer
Dim lastCol As Integer
Dim userResponse As VBA.VbMsgBoxResult
'check with the user if they want to reset
userResponse = VBA.MsgBox("Do you want to clear the previous pricing?", vbYesNo, "Clear Previous Pricing?")
'check the user response
If userResponse = VBA.vbYes Then
'assign object variable to the actual worksheet
Set sH = Sheet5
Set mainPage = Sheet1
Set tbl = mainPage.ListObjects("ModelTbl")
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.ScreenUpdating = False
'determine the start row of the price and customer information page
startRow = Application.Match("*number*", sH.Columns(1), 0)
'set up the start column where we'll dynamically add columns for each model input by the user
startCol = Application.Match("*expire*", sH.Rows(startRow), 0)
'last column
lastCol = sH.Columns("AA").Column
'clear out the old model numbers and formatting
sH.Range(sH.Cells(startRow - 2, startCol + 1), sH.UsedRange.SpecialCells(xlCellTypeLastCell)).Clear
'loop through each row of the table on the main page and populate the price input page with information
For i = 1 To tbl.ListRows.Count
'if the entries are not blank, then populate the next sheet with their model numbers/names
If tbl.DataBodyRange.Cells(i, 1).Value2 <> "" Then
With sH
'remove any previous gray column shading since we've found values
.Columns(startCol + i).Interior.Color = xlColorIndexNone
'add gray color for the top rows
.Cells(startRow - 5, i + startCol).Interior.Color = RGB(191, 191, 191)
.Cells(startRow - 4, i + startCol).Interior.Color = RGB(191, 191, 191)
.Cells(startRow - 3, i + startCol).Interior.Color = RGB(191, 191, 191)
'grab the model numbers from the main page that were entered
.Cells(startRow - 1, i + startCol).Value2 = tbl.DataBodyRange.Cells(i, 1).Value2
.Cells(startRow, i + startCol).Value2 = tbl.DataBodyRange.Cells(i, 3).Value2
'update UI for suggesting input
.Cells(startRow - 2, i + startCol).Value2 = "Enter/Paste"
.Cells(startRow - 2, i + startCol).Interior.Color = RGB(255, 255, 0)
.Cells(startRow - 2, i + startCol).Font.Bold = True
'ensure currenty formatting used
.Columns(i + startCol).NumberFormat = "$#,##0.00"
End With
'update counter for tracking how many models were added
counter = counter + 1
End If
Next
'clean up borders and user interface for user
With sH.Range(sH.Cells(startRow - 2, startCol + 1), sH.Cells(startRow, startCol + counter)).Borders
'thin weight
.Weight = 2
End With
'loop through the unused columns till the last "AA" column
For i = counter + startCol + 1 To lastCol
'set the column colors to help with UI
sH.Columns(i).Interior.Color = RGB(191, 191, 191)
Next
'clean up the autofitting
sH.UsedRange.Columns.AutoFit
'resize to help with view and button visibility
If sH.Columns(2).ColumnWidth < 30 Then
'ideal size if the the autofit made the column too small
sH.Columns(2).ColumnWidth = 30
End If
'reset settings
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub
Many Thanks,
C
