Avoid code repetition by calling common code from another sub

  • I have a code that has an If-else condition in which only the first few lines of each condition differ, the rest of the operation is the same for both. The following is my common code which I have placed in a sub named 'MsgAnswer' :


    Sub MsgAnswer(SrcWb As Workbook, DestSheet As Worksheet, SrcSheet As Worksheet)


    completed = 0
    Application.StatusBar = "Copying In progress..." & Round(completed, 0) & "% completed"


    'Find the last non-blank cell in row ref
    lnCol = SrcWb.Sheets(SourceName).Cells(ref, Columns.Count).End(xlToLeft).Column


    last = lnCol - 1 'To get penultimate column


    Set DestSheet = DestWb.Sheets(DestName)
    Set SrcSheet = SrcWb.Sheets(SourceName)


    destTotalRows = DestSheet.Cells(Rows.Count, 1).End(xlUp).Row 'Finding last non-blank cell in Column 1 in Destination sheet
    MsgBox "Last row is: " & destTotalRows



    For i = 1 To destTotalRows


    destKey = DestSheet.Cells(i, 1)
    If destKey = "" Then GoTo endTry 'Ignoring blanks while looping through destination sheet


    sourceKey = GetSourceKey(destKey)
    If sourceKey = "" Then GoTo endTry 'Ignoring unmatched values while looping through source sheet


    Debug.Print "DestKey", destKey, "SourceKey", sourceKey


    k = DestSheet.Cells(1, 1).EntireColumn.Find(What:=destKey, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row 'Finding row with Destkey in Destination sheet
    j = SrcSheet.Cells(1, 2).EntireColumn.Find(What:=sourceKey, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row 'Finding row with Srckey in Source sheet


    Debug.Print j, k


    Call CopyRange(SrcSheet.Range(Cells(j, 3), Cells(j, 3).End(xlToRight)), DestSheet.Cells(k, 2), completed) 'Copying the data from Source sheet and pasting it onto destiation sheet
    completed = completed + (100 / steps)
    endTry:
    Next i


    SrcWb.Close


    End Sub
    \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
    This is my uncommon code :
    \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
    1) If answer = vbYes Then
    MyFile = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")


    2) ElseIf answer = vbNo Then


    'change the address to suit
    MyFile = Dir(MyDir & "Estimate*.xls*")
    ChDir MyDir


    Set SrcWb = Workbooks.Open(MyDir + MyFile, UpdateLinks:=0)


    \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
    The code before the If-else condition :
    \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\


    Sub CopyRange(fromRange As Range, toRange As Range, completed As Double)
    fromRange.Copy
    toRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False


    Application.StatusBar = "Copying In progress..." & Round(completed, 0) & "% completed"
    DoEvents
    End Sub


    Sub Automate_Estimate()



    Dim MyFile As String, Str As String, MyDir As String, DestWb As Workbook, SrcWb As Workbook
    Dim Rws As Long, Rng As Range
    Dim DestName As String
    Dim SourceName As String
    Dim completed As Double
    Dim flg As Boolean, sh As Worksheet
    Dim ref As Long
    'Dim DestRowCount As Long
    Dim DestColCount As Long
    Dim lnCol As Long
    Dim last As Long
    Dim destKey As String, sourceKey As String
    Dim destTotalRows As Long
    Dim i As Integer, j, k As Integer
    Dim DestSheet As Worksheet
    Dim SrcSheet As Worksheet



    DestName = "x" 'Name of destination sheet
    SourceName = "y" 'Name of Source sheet
    MyDir = "\Path" 'Default directory path"
    Const steps = 22 'Number of rows copied
    ref = 13 'row in Estimate sheet in which 'Grand Total' is present
    Set DestWb = ThisWorkbook 'Setting Destination workbook




    ' disable certain excel features to speed up the process


    Application.DisplayAlerts = False
    'Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
    Application.Calculation = xlCalculationManual


    \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\


    I get an error in my 'MsgAnswer' sub when I call it within If using 'Call MsgAnswer(SrcWb, DestSheet, SrcSheet)' . The error is "ByRef Argument mismatch" and it shows error in the 'for loop' in 'sourceKey = GetSourceKey(destKey)', where GetSourceKey is another function. Any help would be appreciated. Thank you.

  • I told you only yesterday about cross posting (as well as not using code tags) and here you are again. I am closing this thread until you PM me acknowledging my post and agreeing to add links.

Participate now!

Don’t have an account yet? Register yourself now and be a part of our community!