Combining code

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
2,352
Office Version
  1. 365
  2. 2016
Platform
  1. 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

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?
 

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
So why not simply add the save PDF option.....UNTESTED
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, ans As String
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
  MsgBox "Do you want to Save to PDF ??", vbYesNo, "Save Options"
    If vbYes Then Call save_pdf
    sh1.Range("H4").Value = sh1.Range("H4").Value + 1
    With wb2
        .Save
        .Close
    End With
End Sub
 
Upvote 0
I worked it out by myself, using arguments and I was able to remove a heap of duplicate code, YAY
 
Upvote 0
Something else to think about.......
If you are unsure about the outcomes of chnaged / modified / removed code, create a new module, name it "comments", put the code that you want to get rid of into that module, and comment out ALL lines....that way you can always go back to it later, if there is a problem.
 
Upvote 0

Forum statistics

Threads
1,212,927
Messages
6,110,695
Members
448,293
Latest member
jin kazuya

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top