erickamiller143
New Member
- Joined
- Nov 29, 2017
- Messages
- 17
I have some code that I have written. I had it working then made a small tweak to it. The code publishes a letter of customer specific data from a template held in the workbook. I have been tweaking with the original code to change formatting and the eliminate pre-existing SQL queries that are the bane of my existence (just a personal thing). When I added an "or" to a couple of my if statements I started to get compile errors. I have searched and searched for any statement that is not closed properly or if I have too many "End if"'s in there. I have tried to comment out the compile errors just to get the code to step though so I could find the guffaw in my code. I have even printed the code and highlighted it up with 5 different colors. I was two strokes away from being able to present the new format - if I could only find the two stokes. A second pair of eyes would be awesome if anyone were so inclined. - I probobly have too many things declared as I have changed things around and have not cleaned it up yet.
Code:
Option Explicit
Public MRAData As New ADODB.Recordset
Public MRAData2 As New ADODB.Recordset
Public CustData As New ADODB.Recordset
Public MRACatData As New ADODB.Recordset
Public Series As New ADODB.Recordset
Public MRADate As String
Public MRACatInfo As String
Public Path As String
Public start As Range
Public LocationName As String
Public fdObj As Object
Public File As String
Public DirFile As String
Public ws As Worksheet
Public printRng As Range
Public LastRow As Long
Public PageRow As Integer
Public MRAFinal As Worksheet
Public CurRow2 As Integer
Public aw As Worksheet
Public MRADescrip As String
Public MRANew As String
Public MRAOld As String
Public dqty As String
Public dexclude As String
Public dsize As String
Public DWidth As Integer
Public DHeight As Integer
Public Rng1 As Range
Public LngMRADes As Long
Public rHeight As Long
Public TLSD As String
Public t As Integer
Public SD As String
Public SDLetter As String
Public x As Integer
Public Location As String
Public Start2 As Range
Public dict As New Dictionary
Public dictCat As New Dictionary
Public dictMRA As New Dictionary
Public dictPriceCat As New Dictionary
Public oCust As clsCustomer
Public oMRA As ClsMRA
Public i As Long
Public k As Variant
Public rg As Range
Public sh As Worksheet
Public key As Variant
Public PCKey As Variant
Public cKey As Variant
Public o As Variant
Public mCurCol As Long
Public PCKeyTest As String
Public NewHeader As String
Public addrow As String
Public RSMName As String
Public DRow As Integer
Public hNotes As String
Public hNotesValue As New Dictionary
Public h As Variant
Public hValue As String
Public c As Integer
Public d As Integer
Public e As Integer
Public f As Integer
Public g As Integer
Public FindString As String
Public Rng As Range
Sub Button6_Click()
'***********TEST CODE TO CREATE NEW LETTER FORMAT TO HAVE A GRID INSTEAD OF A LIST FOR
' DOOR MRA'S - ONLY SAMPLE ODC HAS THE CORRECTLY FORMATTED DATA TO RUN UNTIL APPROVAL
'***********START WITH OLD CODE THAT CREATES THE INTRODUCTORY FORM LETTER
If PrintLetter = "True" Then GoTo PrintLetterStart
Set aw = ActiveSheet
'PLocation.Show
'PrintLocation = "SAMPLE ODC" '**Remove when approved and reinstate previous line
PrintLocation = "ODC Sample 2"
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Path = Environ$("Userprofile") & "\Desktop\" & "MRA Letters"
MRADate = Format(Date, "yyyymmdd")
Set fdObj = CreateObject("Scripting.FileSystemObject")
If fdObj.FolderExists(Path) Then
GoTo Continue
Else
fdObj.CreateFolder (Path)
End If
Continue:
PrintLetterStart:
MRAOld = "No MRA Old"
dict.RemoveAll
Worksheets("MRA Letter Template").Activate
' Get the range of all the adjacent data using CurrentRegion
Set sh = ThisWorkbook.Worksheets("Contact_Info")
Set rg = sh.Range("A1").CurrentRegion
' read through the data
For i = 2 To rg.Rows.Count
' Create a new clsCustomer object
If rg.Cells(i, 1).Value = PrintLocation Then
Set oCust = New clsCustomer
' Set the values
oCust.BillTo = rg.Cells(i, 1).Value
oCust.Location = rg.Cells(i, 5).Value
oCust.CName = rg.Cells(i, 6).Value
oCust.Address = rg.Cells(i, 7).Value
oCust.Address2 = rg.Cells(i, 8).Value
oCust.DSM = rg.Cells(i, 9).Value
oCust.RSM = rg.Cells(i, 10).Value
' Add the new clsCustomer object to the dictionary
dict.Add oCust.BillTo, oCust
End If
Next i
If dict.Count = 0 And PrintLetter = "True" Then SkipExport = "True"
If dict.Count = 0 And PrintLetter = "True" Then GoTo PrintLetterEnd
'*************Use Dictioanry and Array to complete Form Letter
Sheets("MRA Letter Template").Copy After:=Sheets("MRA Letter Template")
ActiveSheet.Name = "MRA"
Application.Worksheets("MRA").Unprotect
For Each cKey In dict.Keys
Set oCust = dict(cKey)
With oCust
Range("A5").Value = oCust.Location 'Location
Range("A6").Value = oCust.CName
Range("A7").Value = oCust.Address
Range("A8").Value = oCust.Address2 'City State Zip
Range("A10").Value = "Dear " & oCust.CName & ":"
Range("A34").Value = oCust.DSM
Range("A36").Value = oCust.DSM
RSMName = oCust.RSM
Location = oCust.Location
LocatName = oCust.Location
With ActiveSheet.PageSetup
.DifferentFirstPageHeaderFooter = True
.CenterFooter = "&""Times New Roman,Bold""" & oCust.Location & " MRA Discount Schedule"
End With
End With
'******************************************ABOVE TESTED AND WORKS**********************************************************
'***************************Collect all the categories for customer
dictCat.CompareMode = vbTextCompare
Set sh = ThisWorkbook.Worksheets("Input_Data")
Set rg = sh.Range("B1").CurrentRegion
' read through the data
For i = 2 To rg.Rows.Count
If rg.Cells(i, 1).Value = PrintLocation Then
If Not dictCat.Exists(rg.Cells(i, 2).Value) Then dictCat.Add rg.Cells(i, 2).Value, 1
End If
Next i
If dictMRA.Count = 0 And PrintLetter = "True" Then SkipExport = "True"
If dictMRA.Count = 0 And PrintLetter = "True" Then GoTo PrintLetterEnd
'*********** Start MRA List
Set start = Range("A41")
CurRow = 0
CurCol = 0
With start.Offset(CurRow, CurCol)
.Value = PrintLocation & " MRA Discount Schedule"
.Font.Size = 12
.Font.Bold = True
.Font.Underline = True
End With
CurRow = CurRow + 2
Set Start2 = start.Offset(CurRow, CurCol)
'************Start Loop through Categories
For Each key In dictCat.Keys
NewHeader = "Yes"
If Right(key, 5) = "DOORS" Then
If key = "RESIDENTIAL DOORS" Then
'***Create dictionary with Pricing Categories for Door Models
Set sh = ThisWorkbook.Worksheets("Models")
Set rg = sh.Range("A1").CurrentRegion
' read through the data
For i = 2 To rg.Rows.Count
If rg.Cells(i, 1).Value = key Then
If Not dictPriceCat.Exists(rg.Cells(i, 5).Value) Then dictPriceCat.Add rg.Cells(i, 5).Value, 1
End If
Next i
If dictPriceCat.Count > 0 Then
For Each PCKey In dictPriceCat.Keys
mCurCol = 1
'
Set sh = ThisWorkbook.Worksheets("Input_Data")
Set rg = sh.Range("A1").CurrentRegion
' read through the data
For i = 2 To rg.Rows.Count
' Create a new clsCustomer object
If rg.Cells(i, 1).Value = PrintLocation Then
If rg.Cells(i, 2).Value = key Then
PCKeyTest = rg.Cells(i, 3).Value
If PCKey = Application.WorksheetFunction.VLookup(PCKeyTest, Worksheets("Models").Range("B:E"), 4, False) Then
If NewHeader = "Yes" Then
Set hNotesValue = Nothing
' Check for notes to be placed under cat header
For c = 2 To rg.Rows.Count
If rg.Cells(c, 1).Value = PrintLocation And rg.Cells(c, 2).Value = key And rg.Cells(c, 10).Value <> "" Then
If Not hNotesValue.Exists(rg.Cells(c, 10).Value) Then hNotesValue.Add rg.Cells(c, 10).Value, 1
End If
Next c
If hNotesValue.Count > 0 Then hNotes = "Yes"
With start.Offset(CurRow, CurCol)
.Value = key
.Font.Size = 12
.Font.Bold = True
.Font.Underline = True
End With
DRow = CurRow
If hNotes = "Yes" Then
For Each h In hNotesValue
hValue = Application.WorksheetFunction.VLookup(h, Worksheets("CatNotes").Range("A:C"), 3, False)
CurRow = CurRow + 1
rHeight = Application.WorksheetFunction.RoundUp(Len(hValue) / 122, 0)
rHeight = rHeight * 15
With start.Offset(CurRow, CurCol)
.Value = hValue
.WrapText = True
.Range("A1:I1").Merge
.RowHeight = rHeight
.Font.Italic = True
End With
FindString = key
If Trim(FindString) <> "" Then
With Sheets("MRA").Range("A:A")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not Rng Is Nothing Then
Application.Goto Rng, True
For d = 1 To (CurRow + 44) - Rng.Row
If Rng.Rows(-1 + d).PageBreak = xlAutomatic Then
'get the diff between currow and d then add that many rows before Cat Header
For e = 1 To d
Rng.EntireRow.Insert
CurRow = CurRow + 1
Next e
GoTo PBFound3
End If
Next d
PBFound3:
End If
End With
End If
Next h
End If
CurRow = CurRow + 2
NewHeader = "No"
End If
'*****add header here if mcurcol=1
If mCurCol = 1 Then
With start.Offset(CurRow, CurCol + 1)
.Value = PCKey
.Font.Bold = True
End With
DRow = CurRow
CurRow = CurRow + 1
'DRow = CurRow - 1
With start.Offset(CurRow, CurCol)
.Value = "Model"
.Font.Italic = True
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
.Font.Size = 10
End With
With start.Offset(CurRow + 1, CurCol)
.Value = "%"
.Font.Italic = True
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
.Font.Size = 10
End With
'****below will test for pagebreak then move up to find the key or pckey and add lines above to move the data below the natural pagebreaks
FindString = PCKey
If Trim(FindString) <> "" Then
With Sheets("MRA").Range("B:B")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not Rng Is Nothing Then
Application.Goto Rng, True
For d = 1 To (CurRow + 44) - Rng.Row
If Rng.Rows(0 + d).PageBreak = xlAutomatic Then
'get the diff between currow and d then add that many rows before Cat Header
For e = 1 To d
Rng.EntireRow.Insert
CurRow = CurRow + 1
Next e
GoTo PBFound
End If
Next d
PBFound:
End If
End With
End If
End If
With start.Offset(CurRow, mCurCol)
.Value = Application.WorksheetFunction.VLookup(PCKeyTest, Worksheets("Models").Range("B:C"), 2, False)
.Borders.LineStyle = xlContinuous
.Borders.Color = RGB(220, 220, 220)
.Interior.Color = RGB(240, 240, 240)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Size = 10
.Font.Bold = True
.WrapText = True
End With
With start.Offset(CurRow + 1, mCurCol)
.Value = rg.Cells(i, 5).Text
.NumberFormat = "0.00"
.Borders.LineStyle = xlContinuous
.Borders.Color = RGB(220, 220, 220)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Size = 10
.WrapText = True
End With
mCurCol = mCurCol + 1
End If
End If
End If
Next i
If mCurCol > 1 Then CurRow = CurRow + 3
Next PCKey
End If
End If
If Not key = "RESIDENTIAL DOORS" Then
If Not key = "SHEET DOORS" Then
'***Create dictionary with Pricing Categories for Door Models
Set sh = ThisWorkbook.Worksheets("Models")
Set rg = sh.Range("A1").CurrentRegion
' read through the data
For i = 2 To rg.Rows.Count
If rg.Cells(i, 1).Value = key Then
If Not dictPriceCat.Exists(rg.Cells(i, 5).Value) Then dictPriceCat.Add rg.Cells(i, 5).Value, 1
End If
Next i
If dictPriceCat.Count > 0 Then
For Each PCKey In dictPriceCat.Keys
mCurCol = 1
'
Set sh = ThisWorkbook.Worksheets("Input_Data")
Set rg = sh.Range("A1").CurrentRegion
' read through the data
For i = 2 To rg.Rows.Count
' Create a new clsCustomer object
If rg.Cells(i, 1).Value = PrintLocation Then
If rg.Cells(i, 2).Value = key Then
PCKeyTest = rg.Cells(i, 3).Value
If PCKey = Application.WorksheetFunction.VLookup(PCKeyTest, Worksheets("Models").Range("B:E"), 4, False) Then
If NewHeader = "Yes" Then
hNotes = "No"
' Check for notes to be placed under cat header
Set hNotesValue = Nothing
For c = 2 To rg.Rows.Count
If rg.Cells(c, 1).Value = PrintLocation And rg.Cells(c, 2).Value = key And rg.Cells(c, 10).Value <> "" Then
If Not hNotesValue.Exists(rg.Cells(c, 10).Value) Then hNotesValue.Add rg.Cells(c, 10).Value, 1
End If
Next c
If hNotesValue.Count > 0 Then hNotes = "Yes"
With start.Offset(CurRow, CurCol)
.Value = key
.Font.Size = 12
.Font.Bold = True
.Font.Underline = True
End With
If hNotes = "Yes" Then
For Each h In hNotesValue
hValue = Application.WorksheetFunction.VLookup(h, Worksheets("CatNotes").Range("A:C"), 3, False)
CurRow = CurRow + 1
rHeight = Application.WorksheetFunction.RoundUp(Len(hValue) / 122, 0)
rHeight = rHeight * 15
With start.Offset(CurRow, CurCol)
.Value = hValue
.WrapText = True
.Range("A1:I1").Merge
.RowHeight = rHeight
.Font.Italic = True
End With
FindString = key
If Trim(FindString) <> "" Then
With Sheets("MRA").Range("A:A")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not Rng Is Nothing Then
Application.Goto Rng, True
For d = 1 To (CurRow + 44) - Rng.Row
If Rng.Rows(0 + d).PageBreak = xlAutomatic Then
'get the diff between currow and d then add that many rows before Cat Header
For e = 1 To d
Rng.EntireRow.Insert
CurRow = CurRow + 1
Next e
GoTo PBFound4
End If
Next d
PBFound4:
End If
End With
End If
Next h
End If
CurRow = CurRow + 2
NewHeader = "No"
End If
'*****add header here if mcurcol=1
If mCurCol = 1 Then
CurRow2 = CurRow
With start.Offset(CurRow, CurCol + 1)
.Value = PCKey
.Font.Bold = True
'.Font.Italic = True
.Font.Size = 11
End With
DRow = CurRow
CurRow = CurRow + 1
With start.Offset(CurRow, CurCol)
.Value = "Model"
.Font.Italic = True
.Font.Size = 10
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
.EntireRow.AutoFit
End With
With start.Offset(CurRow + 1, CurCol)
.Value = "%"
.Font.Size = 10
.Font.Italic = True
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
.EntireRow.AutoFit
End With
FindString = PCKey
If Trim(FindString) <> "" Then
With Sheets("MRA").Range("B:B")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not Rng Is Nothing Then
Application.Goto Rng, True
For d = 1 To (CurRow + 44) - Rng.Row
If Rng.Rows(0 + d).PageBreak = xlAutomatic Then
'get the diff between currow and d then add that many rows before Cat Header
For e = 1 To d
Rng.EntireRow.Insert
CurRow = CurRow + 1
Next e
GoTo PBFound6
End If
Next d
PBFound6:
End If
End With
End If
End If
With start.Offset(CurRow, mCurCol)
.Value = rg.Cells(i, 3).Text
.Font.Size = 10
.Font.Bold = True
.Borders.LineStyle = xlContinuous
.Borders.Color = RGB(220, 220, 220)
.Interior.Color = RGB(240, 240, 240)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
End With
With start.Offset(CurRow + 1, mCurCol)
.Value = rg.Cells(i, 5).Text
.NumberFormat = "0.00"
.Font.Size = 10
.Borders.LineStyle = xlContinuous
.Borders.Color = RGB(220, 220, 220)
.HorizontalAlignment = xlCenter
.WrapText = True
End With
mCurCol = mCurCol + 1
End If
End If
End If
Next i
If mCurCol > 1 Then CurRow = CurRow + 3
Next PCKey
End If
End If
If key = "SHEET DOORS" Then
'***Create dictionary with Pricing Categories for Door Models
Set sh = ThisWorkbook.Worksheets("Models")
Set rg = sh.Range("A1").CurrentRegion
' read through the data
For i = 2 To rg.Rows.Count
If rg.Cells(i, 1).Value = key Then
If Not dictPriceCat.Exists(rg.Cells(i, 5).Value) Then dictPriceCat.Add rg.Cells(i, 5).Value, 1
End If
Next i
If dictPriceCat.Count > 0 Then
For Each PCKey In dictPriceCat.Keys
mCurCol = 1
'
Set sh = ThisWorkbook.Worksheets("Input_Data")
Set rg = sh.Range("A1").CurrentRegion
' read through the data
For i = 2 To rg.Rows.Count
' Create a new clsCustomer object
If rg.Cells(i, 1).Value = PrintLocation Then
If rg.Cells(i, 2).Value = key Then
PCKeyTest = rg.Cells(i, 3).Value
If PCKey = Application.WorksheetFunction.VLookup(PCKeyTest, Worksheets("Models").Range("B:E"), 4, False) Then
If NewHeader = "Yes" Then
' Check for notes to be placed under cat header
Set hNotesValue = Nothing
For c = 2 To rg.Rows.Count
If rg.Cells(c, 1).Value = PrintLocation And rg.Cells(c, 2).Value = key And rg.Cells(c, 10).Value <> "" Then
If Not hNotesValue.Exists(rg.Cells(c, 10).Value) Then hNotesValue.Add rg.Cells(c, 10).Value, 1
End If
Next c
If hNotesValue.Count > 0 Then hNotes = "Yes"
With start.Offset(CurRow, CurCol)
.Value = key
.Font.Size = 12
.Font.Bold = True
.Font.Underline = True
End With
DRow = CurRow
If hNotes = "Yes" Then
For Each h In hNotesValue
hValue = Application.WorksheetFunction.VLookup(h, Worksheets("CatNotes").Range("A:C"), 3, False)
CurRow = CurRow + 1
rHeight = Application.WorksheetFunction.RoundUp(Len(hValue) / 122, 0)
rHeight = rHeight * 15
With start.Offset(CurRow, CurCol)
.Value = hValue
.WrapText = True
.Range("A1:I1").Merge
.RowHeight = rHeight
.Font.Italic = True
End With
FindString = key
If Trim(FindString) <> "" Then
With Sheets("MRA").Range("A:A")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not Rng Is Nothing Then
Application.Goto Rng, True
For d = 1 To (CurRow + 41) - Rng.Row
If Rng.Rows(0 + d).PageBreak = xlAutomatic Then
'get the diff between currow and d then add that many rows before Cat Header
For e = 1 To d
Rng.EntireRows.Insert
Next e
GoTo PBFound5
End If
Next d
PBFound5:
End If
End With
End If
Next h
End If
CurRow = CurRow + 2
If start.Rows(CurRow - 1).PageBreak = xlPageBreakAutomatic Or start.Rows(CurRow - 2).PageBreak = xlPageBreakAutomatic Then
start.Rows(DRow).EntireRow.Insert
start.Rows(DRow).EntireRow.Insert
End If
NewHeader = "No"
End If
'*****add header here if mcurcol=1
If mCurCol = 1 Then
With start.Offset(CurRow, CurCol)
.Value = "Model"
.Font.Italic = True
.Font.Size = 10
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
.EntireRow.AutoFit
End With
With start.Offset(CurRow + 1, CurCol)
.Value = "%"
.Font.Size = 10
.Font.Italic = True
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
.EntireRow.AutoFit
End With
If start.Rows(CurRow - 1).PageBreak = xlPageBreakAutomatic Or start.Rows(CurRow - 2).PageBreak = xlPageBreakAutomatic Or start.Rows(CurRow - 3).PageBreak = xlPageBreakAutomatic Or start.Rows(CurRow - 4).PageBreak = xlPageBreakAutomatic Then
start.Rows(DRow).EntireRow.Insert
start.Rows(DRow).EntireRow.Insert
start.Rows(DRow).EntireRow.Insert
CurRow = CurRow + 3
End If
End If
With start.Offset(CurRow, mCurCol)
.Value = rg.Cells(i, 3).Text
.Font.Size = 10
.Font.Bold = True
.Borders.LineStyle = xlContinuous
.Borders.Color = RGB(220, 220, 220)
.Interior.Color = RGB(240, 240, 240)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
End With
With start.Offset(CurRow + 1, mCurCol)
.Value = rg.Cells(i, 5).Text
.NumberFormat = "0.00"
.Font.Size = 10
.Borders.LineStyle = xlContinuous
.Borders.Color = RGB(220, 220, 220)
.HorizontalAlignment = xlCenter
.WrapText = True
End With
mCurCol = mCurCol + 1
End If
End If
End If
Next i
If mCurCol > 1 Then CurRow = CurRow + 3
Next PCKey
End If
End If
End If
End If
'*************Start Options Code****************
If Not Right(key, 5) = "DOORS" Then
If Not key = "TRUCKLOAD ORDERS REQUIRED" Or key = "SECTION SETS" Then
NewHeader = "Yes"
mCurCol = 1
'
Set sh = ThisWorkbook.Worksheets("Input_Data")
Set rg = sh.Range("A1").CurrentRegion
' read through the data
For i = 2 To rg.Rows.Count
' Create a new clsCustomer object
If rg.Cells(i, 1).Value = PrintLocation Then
If rg.Cells(i, 2).Value = key Then
If NewHeader = "Yes" Then
Set hNotesValue = Nothing
hNotes = "No"
' Check for notes to be placed under cat header
For c = 2 To rg.Rows.Count
If rg.Cells(c, 1).Value = PrintLocation And rg.Cells(c, 2).Value = key And rg.Cells(c, 10).Value <> "" Then
If Not hNotesValue.Exists(rg.Cells(c, 10).Value) Then hNotesValue.Add rg.Cells(c, 10).Value, 1
End If
Next c
If hNotesValue.Count > 0 Then hNotes = "Yes"
With start.Offset(CurRow, CurCol)
.Value = key
.Font.Size = 12
.Font.Bold = True
.Font.Underline = True
End With
If hNotes = "Yes" Then
DRow = CurRow
For Each h In hNotesValue
hValue = Application.WorksheetFunction.VLookup(h, Worksheets("CatNotes").Range("A:C"), 3, False)
CurRow = CurRow + 1
rHeight = Application.WorksheetFunction.RoundUp(Len(hValue) / 122, 0)
rHeight = rHeight * 15
With start.Offset(CurRow, CurCol)
.Value = hValue
.WrapText = True
.Range("A1:I1").Merge
.RowHeight = rHeight
.Font.Italic = True
End With
'*****Find PageBreak then find the Cat Header and add rows to pagebreak
FindString = key
If Trim(FindString) <> "" Then
With Sheets("MRA").Range("A:A")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not Rng Is Nothing Then
Application.Goto Rng, True
For d = 1 To (CurRow + 41) - Rng.Row
If Rng.Rows(0 + d).PageBreak = xlAutomatic Then
'get the diff between currow and d then add that many rows before Cat Header
For e = 1 To d
Rng.EntireRow.Insert
CurRow = CurRow + 1
Next e
GoTo PBFound7
End If
Next d
PBFound7:
End If
End With
End If
Next h
End If
CurRow = CurRow + 1
With start.Offset(CurRow, CurCol + 1)
.Value = "Item Description"
.Font.Bold = True
.Range("A1:E1").Merge
End With
With start.Offset(CurRow, CurCol + 7)
.Value = "MRA"
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
If start.Rows(CurRow - 1).PageBreak = xlPageBreakAutomatic Or start.Rows(CurRow - 2).PageBreak = xlPageBreakAutomatic Then
start.Rows(CurRow - 2).EntireRow.Insert
start.Rows(CurRow - 2).EntireRow.Insert
start.Rows(CurRow - 2).EntireRow.Insert
start.Rows(CurRow - 2).EntireRow.Insert
'start.Rows(CurRow - 2).EntireRow.Insert
CurRow = CurRow + 4
End If
CurRow = CurRow + 1
NewHeader = "No"
hNotes = "No"
End If
With start.Offset(CurRow, CurCol + 1)
.Value = rg.Cells(i, 3).Value
.WrapText = True
.Range("A1:E1").Merge
.EntireRow.AutoFit
End With
If rg.Cells(i, 4).Value = "%" Then
With start.Offset(CurRow, CurCol + 7)
'.NumberFormat = "0.00"
.Value = rg.Cells(i, 5).Text & rg.Cells(i, 4).Value & " " & rg.Cells(i, 6).Value
'.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
End With
Else
With start.Offset(CurRow, CurCol + 7)
.Cells.NumberFormat = "General"
.Value = rg.Cells(i, 4).Text & rg.Cells(i, 5).Text & " " & rg.Cells(i, 6).Text
'.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
'.NumberFormat = "0.00"
End With
'CurRow = CurRow + 1
End If
CurRow = CurRow + 1
If start.Rows(CurRow).PageBreak = xlPageBreakAutomatic Then
start.Rows(CurRow).EntireRow.Insert
start.Rows(CurRow).EntireRow.Insert
start.Rows(CurRow).EntireRow.Insert
start.Rows(CurRow).EntireRow.Insert
'start.Rows(CurRow + 1).EntireRow.Insert
With start.Offset(CurRow + 1, CurCol)
.Value = key & " Contd"
.Font.Size = 12
.Font.Bold = True
.Font.Underline = True
End With
With start.Offset(CurRow + 2, CurCol + 1)
.Value = "Item Description"
.Font.Bold = True
.Range("A1:E1").Merge
.EntireRow.AutoFit
End With
With start.Offset(CurRow + 2, CurCol + 7)
.Value = "MRA"
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
CurRow = CurRow + 3
'End If
End If
'Next i
CurRow = CurRow + 1
End If
End If
If key = "TRUCKLOAD ORDERS REQUIRED" Or key = "SECTION SETS" Then
NewHeader = "Yes"
' ***Create dictionary with Pricing Categories for Door Models
Set sh = ThisWorkbook.Worksheets("Input_Data")
Set rg = sh.Range("A1").CurrentRegion
Set dictPriceCat = Nothing
' read through the data
For f = 2 To rg.Rows.Count
If rg.Cells(f, 1).Value = PrintLocation And rg.Cells(f, 2).Value = key Then
If Not dictPriceCat.Exists(rg.Cells(f, 3).Value) Then dictPriceCat.Add rg.Cells(f, 3).Value, 1
End If
Next f
If dictPriceCat.Count > 0 Then
For Each PCKey In dictPriceCat.Keys
For g = 1 To 2 '****want to go through the data 2x beofre moving to next model group
mCurCol = 1
Set sh = ThisWorkbook.Worksheets("Input_Data")
Set rg = sh.Range("A1").CurrentRegion
' read through the data
If g = 1 Then
SDLetter = "S"
SD = " Single"
Else
SDLetter = "D"
SD = " Double"
End If
If rg.Cells(i, 1).Value = PrintLocation Then
If rg.Cells(i, 2).Value = key Then
If rg.Cells(i, 3).Value = PCKey Then
If rg.Cells(i, 8).Value = SDLetter Then
If mCurCol = 1 And NewHeader = "No" Then
With start.Offset(CurRow, CurCol + 1)
.Value = PCKey & SD
.Font.Bold = True
End With
With start.Offset(CurRow + 1, CurCol)
.Value = "Size"
.Font.Italic = True
.HorizontalAlignment = xlRight
End With
If key = "Section Sets" Then
With start.Offset(CurRow + 2, CurCol)
.Value = "$"
.Font.Italic = True
.HorizontalAlignment = xlRight
End With
Else
With start.Offset(CurRow + 2, CurCol)
.Value = "%"
.Font.Italic = True
.HorizontalAlignment = xlRight
End With
End If
DRow = CurRow
CurRow = CurRow + 1
mCurCol = CurCol + 1
End If
If NewHeader = "Yes" Then
Set sh = ThisWorkbook.Worksheets("Input_Data")
Set rg = sh.Range("A1").CurrentRegion
Set hNotesValue = Nothing
hNotes = "No"
For c = 2 To rg.Rows.Count
If rg.Cells(c, 1).Value = PrintLocation And rg.Cells(c, 2).Value = key And rg.Cells(c, 10).Value <> "" Then
If Not hNotesValue.Exists(rg.Cells(c, 10).Value) Then hNotesValue.Add rg.Cells(c, 10).Value, 1
End If
Next c
If hNotesValue.Count > 0 Then hNotes = "Yes"
With start.Offset(CurRow, CurCol)
.Value = key
.Font.Size = 12
.Font.Bold = True
.Font.Underline = True
End With
'Go through all the notes for the Header
If hNotes = "Yes" Then
For Each h In hNotesValue
hValue = Application.WorksheetFunction.VLookup(h, Worksheets("CatNotes").Range("A:C"), 3, False)
CurRow = CurRow + 1
rHeight = Application.WorksheetFunction.RoundUp(Len(hValue) / 122, 0)
rHeight = rHeight * 15
With start.Offset(CurRow, CurCol)
.Value = hValue
.WrapText = True
.Range("A1:I1").Merge
.RowHeight = rHeight
.Font.Italic = True
End With
FindString = key
If Trim(FindString) <> "" Then
With Sheets("MRA").Range("A:A")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not Rng Is Nothing Then
Application.Goto Rng, True
For d = 1 To (CurRow + 44) - Rng.Row
If Rng.Rows(-1 + d).PageBreak = xlAutomatic Then
'get the diff between currow and d then add that many rows before Cat Header
For e = 1 To d
Rng.EntireRow.Insert
CurRow = CurRow + 1
Next e
GoTo PBFound2
End If
Next d
PBFound2:
End If
End With
End If
Next h
End If
CurRow = CurRow + 2
With start.Offset(CurRow, CurCol + 1)
.Value = PCKey & SD
.Font.Bold = True
End With
With start.Offset(CurRow + 1, CurCol)
.Value = "Size"
.Font.Italic = True
.HorizontalAlignment = xlRight
End With
With start.Offset(CurRow + 2, CurCol)
.Value = "%"
.Font.Italic = True
.HorizontalAlignment = xlRight
End With
If start.Rows(CurRow).PageBreak = xlPageBreakAutomatic Or start.Rows(CurRow + 1).PageBreak = xlPageBreakAutomatic Or start.Rows(CurRow + 2).PageBreak = xlPageBreakAutomatic Or start.Rows(CurRow + 3).PageBreak = xlPageBreakAutomatic Then
start.Rows(CurRow + 1).EntireRow.Insert
start.Rows(CurRow + 1).EntireRow.Insert
start.Rows(CurRow + 1).EntireRow.Insert
CurRow = CurRow + 3
End If
CurRow = CurRow + 1
NewHeader = "No"
mCurCol = CurCol + 1
End If
With start.Offset(CurRow, mCurCol)
.Value = rg.Cells(i, 9).Text
.Font.Size = 10
.Font.Bold = True
.Borders.LineStyle = xlContinuous
.Borders.Color = RGB(220, 220, 220)
.Interior.Color = RGB(240, 240, 240)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
End With
With start.Offset(CurRow + 1, mCurCol)
.Value = rg.Cells(i, 5).Text
.NumberFormat = "0.00"
.Font.Size = 10
.Borders.LineStyle = xlContinuous
.Borders.Color = RGB(220, 220, 220)
.HorizontalAlignment = xlCenter
.WrapText = True
End With
mCurCol = mCurCol + 1
End If
End If
End If
End If
CurRow = CurRow + 3
Next g
Next PCKey
End If
End If
Next key
CurRow = CurRow + 2
Set Start2 = start.Offset(CurRow, CurCol)
start.Offset(CurRow, CurCol).Value = "Approved,"
With start.Offset(CurRow + 2, CurCol)
.Value = RSMName
.Font.Name = "Monotype Corsiva"
.Font.Size = 16
End With
start.Offset(CurRow + 4, CurCol).Value = RSMName
start.Offset(CurRow + 5, CurCol).Value = "Regional Sales Manager"
If start.Rows(CurRow + 2).PageBreak = xlPageBreakAutomatic Then
ActiveSheet.HPageBreaks.Add Before:=Start2
Else
End If
If start.Rows(CurRow + 4).PageBreak = xlPageBreakAutomatic Then
ActiveSheet.HPageBreaks.Add Before:=Start2
Else
End If
If start.Rows(CurRow + 5).PageBreak = xlPageBreakAutomatic Then
ActiveSheet.HPageBreaks.Add Before:=Start2
Else
End If
FileName = oCust.BillTo & " " & MRADate & ".pdf"
CustDataName = oCust.BillTo
If PrintLetter = "True" Then GoTo PrintLetterEnd
DirFile = Path & FileName
ClosePDF
If Len(Dir$(DirFile)) > 0 Then
Kill (DirFile)
End If
ActiveSheet.ExportAsFixedFormat xlTypePDF, Path & "\" & CustDataName & " " & MRADate & ".pdf"
Worksheets("MRA").Delete
End If
Next cKey
If PrintLetter = "True" Then GoTo PrintLetterEnd
aw.Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "MRA Letter for " & PrintLocation & " is complete and can be found in the MRA Letters folder on your desktop."
PrintLetterEnd:
End Sub
Last edited:
