dpaton05
Well-known Member
- Joined
- Aug 14, 2018
- Messages
- 2,352
- Office Version
- 365
- 2016
- Platform
- Windows
I have two subs that are almost identical. The only difference is and one of the subs also prints to pdf.
Here are the two subs
The cmdSendNP just refers to the send procedure but without printing to pdf
They call a couple of other subs that are called
cmdSend calls this sub
cmdSendNP calls this sub
The AddName sub calls a sub to save as pdf.
Having to keep both of these procedures updated is a pain and I was wondering if someone could help me consolidate cmdSend and cmdSendNP to one procedure please?
Here are the two subs
VBA Code:
Sub cmdSend()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim desWS As Worksheet, srcWS As Worksheet
Set srcWS = ThisWorkbook.Sheets("CSS_quote_sheet")
Set desWS = ThisWorkbook.Sheets("Costing_tool")
Dim lastRow1 As Long, lastRow2 As Long
Dim i As Long, x As Long, header As Range
lastRow1 = srcWS.Range("B" & srcWS.Rows.Count).End(xlUp).Row
lastRow2 = desWS.Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
With srcWS.Range("A:A,B:B,D:D,H:H")
If lastRow2 < 5 Then
lastRow2 = 5
For i = 1 To .Areas.Count
x = .Areas(i).Column
Set header = desWS.Rows(4).Find(.Areas(i).Cells(10), LookIn:=xlValues, Lookat:=xlWhole)
If Not header Is Nothing Then
srcWS.Range(srcWS.Cells(11, x), srcWS.Cells(lastRow1, x)).Copy
desWS.Cells(lastRow2, header.Column).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next i
With desWS
If .Range("A" & .Rows.Count).End(xlUp).Row > 5 Then
desWS.ListObjects.Item("tblCosting").ListRows.Add
.ListObjects.Item("tblCosting").DataBodyRange.Columns(1).NumberFormat = "dd/mm/yyyy"
End If
.Range("C" & lastRow2 & ":C" & .Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row) = srcWS.Range("H4")
.Range("D" & lastRow2 & ":D" & .Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row) = srcWS.Range("B5")
.Range("F" & lastRow2 & ":F" & .Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row) = srcWS.Range("B7")
.Range("G" & lastRow2 & ":G" & .Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row) = srcWS.Range("B6")
End With
Else
lastRow2 = desWS.Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
desWS.ListObjects.Item("tblCosting").ListRows.Add
For i = 1 To .Areas.Count
x = .Areas(i).Column
Set header = desWS.Rows(4).Find(.Areas(i).Cells(10), LookIn:=xlValues, Lookat:=xlWhole)
If Not header Is Nothing Then
srcWS.Range(srcWS.Cells(11, x), srcWS.Cells(lastRow1, x)).Copy
desWS.Cells(lastRow2 + 1, header.Column).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next i
With desWS
.Range("C" & lastRow2 + 1 & ":C" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("H4")
.Range("D" & lastRow2 + 1 & ":D" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B5")
.Range("F" & lastRow2 + 1 & ":F" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B7")
.Range("G" & lastRow2 + 1 & ":G" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B6")
End With
End If
End With
desWS.ListObjects("tblCosting").ListColumns(9).Range.NumberFormat = "$#,##0.00"
desWS.ListObjects("tblCosting").Sort.SortFields.Clear
desWS.ListObjects("tblCosting").Sort.SortFields. _
Add Key:=desWS.Cells(, 1), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
With desWS.ListObjects("tblCosting").Sort
.header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'With desWS.ListObjects("tblCosting")
'Call AltColours
'End With
Call AddName
With Application
.CutCopyMode = False
.EnableEvents = True
.ScreenUpdating = True
End With
Dim oLst As ListObject
Dim lr As Long, rng As Range
lr = desWS.Cells(Rows.Count, "A").End(xlUp).Row
For i = lr To 4 Step -1
Set rng = desWS.Cells(i, 1)
If WorksheetFunction.CountBlank(rng) = 1 Then
desWS.Rows(i).Delete
End If
Next i
End Sub
VBA Code:
Sub cmdSendNP()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim desWS As Worksheet, srcWS As Worksheet
Set srcWS = ThisWorkbook.Sheets("CSS_quote_sheet")
Set desWS = ThisWorkbook.Sheets("Costing_tool")
Dim lastRow1 As Long, lastRow2 As Long
Dim i As Long, x As Long, header As Range
lastRow1 = srcWS.Range("B" & srcWS.Rows.Count).End(xlUp).Row
lastRow2 = desWS.Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
With srcWS.Range("A:A,B:B,D:D,H:H")
If lastRow2 < 5 Then
lastRow2 = 5
For i = 1 To .Areas.Count
x = .Areas(i).Column
Set header = desWS.Rows(4).Find(.Areas(i).Cells(10), LookIn:=xlValues, Lookat:=xlWhole)
If Not header Is Nothing Then
srcWS.Range(srcWS.Cells(11, x), srcWS.Cells(lastRow1, x)).Copy
desWS.Cells(lastRow2, header.Column).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next i
With desWS
If .Range("A" & .Rows.Count).End(xlUp).Row > 5 Then
.ListObjects.Item("tblCosting").ListRows.Add
.ListObjects.Item("tblCosting").DataBodyRange.Columns(1).NumberFormat = "dd/mm/yyyy"
'This line isn't working to add the currency format to the prices
.ListObjects.Item("tblCosting").DataBodyRange.Columns(10).NumberFormat = "$#,##0.00"
End If
.Range("C" & lastRow2 & ":C" & .Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row) = srcWS.Range("H4")
.Range("D" & lastRow2 & ":D" & .Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row) = srcWS.Range("B5")
.Range("F" & lastRow2 & ":F" & .Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row) = srcWS.Range("B7")
.Range("G" & lastRow2 & ":G" & .Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row) = srcWS.Range("B6")
End With
Else
lastRow2 = desWS.Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
desWS.ListObjects.Item("tblCosting").ListRows.Add
For i = 1 To .Areas.Count
x = .Areas(i).Column
Set header = desWS.Rows(4).Find(.Areas(i).Cells(10), LookIn:=xlValues, Lookat:=xlWhole)
If Not header Is Nothing Then
srcWS.Range(srcWS.Cells(11, x), srcWS.Cells(lastRow1, x)).Copy
desWS.Cells(lastRow2 + 1, header.Column).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next i
With desWS
.Range("C" & lastRow2 + 1 & ":C" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("H4")
.Range("D" & lastRow2 + 1 & ":D" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B5")
.Range("F" & lastRow2 + 1 & ":F" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B7")
.Range("G" & lastRow2 + 1 & ":G" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B6")
End With
End If
End With
desWS.ListObjects("tblCosting").Sort.SortFields.Clear
desWS.ListObjects("tblCosting").Sort.SortFields. _
Add Key:=desWS.Cells(, 1), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
With desWS.ListObjects("tblCosting").Sort
.header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Call AddNameNP
'With desWS.ListObjects("tblCosting")
'Call AltColours
'End With
With Application
.CutCopyMode = False
.EnableEvents = True
.ScreenUpdating = True
End With
Dim oLst As ListObject
Dim lr As Long, rng As Range
lr = desWS.Cells(Rows.Count, "A").End(xlUp).Row
For i = lr To 4 Step -1
Set rng = desWS.Cells(i, 1)
If WorksheetFunction.CountBlank(rng) = 1 Then
desWS.Rows(i).Delete
End If
Next i
End Sub
The cmdSendNP just refers to the send procedure but without printing to pdf
They call a couple of other subs that are called
cmdSend calls this sub
VBA Code:
Sub AddName()
Dim wb1 As Workbook, wb2 As Workbook, LastRow As Single, site As String
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
Dim f As Range, client As Variant, Ref As String, ref2 As Integer
Set wb1 = ThisWorkbook
Set sh1 = wb1.Sheets("CSS_quote_sheet")
'set site = site name selected on Start_here sheet
site = ThisWorkbook.Worksheets("Start_here").Range("H9")
'open site name file for the site that has been selected
Select Case site
Case "Wes"
If Not isFileOpen("Wes_names.xlsm") Then
Workbooks.Open ThisWorkbook.Path & "\" & "Client list" & "\" & "Wes_names.xlsm"
End If
Set wb2 = Workbooks("Wes_names")
Set sh2 = wb2.Sheets("Wes_names")
Case "Wag"
If Not isFileOpen("Wag.xlsm") Then
Workbooks.Open ThisWorkbook.Path & "\" & "Client list" & "\" & "Wag_names.xlsm"
End If
Set wb2 = Workbooks("Wag_names")
Set sh2 = wb2.Sheets("Wag_names")
Case "Al"
If Not isFileOpen("Al_names.xlsm") Then
Workbooks.Open ThisWorkbook.Path & "\" & "Client list" & "\" & "Al_names.xlsm"
End If
Set wb2 = Workbooks("Al_names")
Set sh2 = wb2.Sheets("Al_names")
End Select
sh2.Activate
client = sh1.Range("B5")
Set f = sh2.Range("A:A").Find(client, , xlValues, xlWhole)
If f Is Nothing Then
sh2.Range("A" & Rows.Count).End(xlUp)(2) = client
End If
Range("A2", Range("A2").End(xlDown)).Sort Key1:=Range("A2"), Order1:=xlAscending, header:=xlNo
wb1.Activate
Call save_pdf
sh1.Range("H4").Value = sh1.Range("H4").Value + 1
With wb2
.Save
.Close
End With
End Sub
cmdSendNP calls this sub
VBA Code:
Sub AddNameNP()
Dim wb1 As Workbook, wb2 As Workbook, LastRow As Single, site As String
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
Dim f As Range, client As Variant, Ref As String, ref2 As Integer
Set wb1 = ThisWorkbook
Set sh1 = wb1.Sheets("CSS_quote_sheet")
site = ThisWorkbook.Worksheets("Start_here").Range("H9")
Select Case site
Case "Wes"
If Not isFileOpen("Wes_names.xlsm") Then
Workbooks.Open ThisWorkbook.Path & "\" & "Client list" & "\" & "Wes_names.xlsm"
End If
Set wb2 = Workbooks("Wes_names")
Set sh2 = wb2.Sheets("Wes_names")
Case "Wag"
If Not isFileOpen("Wag_names.xlsm") Then
Workbooks.Open ThisWorkbook.Path & "\" & "Client list" & "\" & "Wag_names.xlsm"
End If
Set wb2 = Workbooks("Wag_names")
Set sh2 = wb2.Sheets("Wag_names")
Case "Al"
If Not isFileOpen("Al_names.xlsm") Then
Workbooks.Open ThisWorkbook.Path & "\" & "Client list" & "\" & "Al_names.xlsm"
End If
Set wb2 = Workbooks("Al_names")
Set sh2 = wb2.Sheets("Al_names")
End Select
sh2.Activate
client = sh1.Range("B5")
Set f = sh2.Range("A:A").Find(client, , xlValues, xlWhole)
If f Is Nothing Then
sh2.Range("A" & Rows.Count).End(xlUp)(2) = client
End If
Range("A2", Range("A2").End(xlDown)).Sort Key1:=Range("A2"), Order1:=xlAscending, header:=xlNo
With wb2
.Save
.Close
End With
wb1.Activate
sh1.Range("H4").Value = sh1.Range("H4").Value + 1
End Sub
The AddName sub calls a sub to save as pdf.
VBA Code:
Sub save_pdf()
Dim folderChoice
Dim i As Integer
Call NoBorder
folderChoice = setupFolders()
ChDir (folderChoice)
ActiveSheet.Select
Call exportSheet(ActiveSheet.Range("B5").Value & " - " & ActiveSheet.Range("H4").Value)
Call border
End Sub
Having to keep both of these procedures updated is a pain and I was wondering if someone could help me consolidate cmdSend and cmdSendNP to one procedure please?