Vba 通过在函数中包含If-else的两个条件来避免代码重复_Vba_Excel

Vba 通过在函数中包含If-else的两个条件来避免代码重复

vba excel

Vba 通过在函数中包含If-else的两个条件来避免代码重复,vba,excel,Vba,Excel,我有一个带有If yes和If no条件的代码。每个条件的前几行是不同的，而其余几行则完全相同并执行相同的操作。有人能指出我如何将代码中完全相同的部分合并到一个可以在任何一种情况下调用的函数中吗？我不太清楚我该如何推进这项工作。任何帮助都将不胜感激。多谢各位这是我的代码： Sub CopyRange(fromRange As Range, toRange As Range, completed As Double) fromRange.Copy toRange.PasteSpecial Pa

我有一个带有If yes和If no条件的代码。每个条件的前几行是不同的，而其余几行则完全相同并执行相同的操作。有人能指出我如何将代码中完全相同的部分合并到一个可以在任何一种情况下调用的函数中吗？我不太清楚我该如何推进这项工作。任何帮助都将不胜感激。多谢各位

这是我的代码：

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 y 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    
Application.ScreenUpdating = False

Dim answer As Integer
answer = MsgBox("If you want to select a specific file click Yes, if you 
 want to go to default path, click No",vbYesNo + vbQuestion, "User Specified Path")

  If answer = vbYes Then                                                              

    MyFile = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")

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


    Set SrcWb = Workbooks.Open(MyFile, UpdateLinks:=0)                                  'Opening the Source workbook

        (REPETITIVE CODE STARTS HERE)


        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 endFor                                    'Ignoring blanks while looping through destination sheet

            sourceKey = GetSourceKey(destKey)
            If sourceKey = "" Then GoTo endFor                                  '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)
 endFor:
        Next i

        SrcWb.Close
        Application.StatusBar = "Copying is complete"


  DoEvents

      ElseIf answer = vbNo Then         

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

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


       (REPETITIVE CODE STARTS HERE)

       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 endFor                                    'Ignoring blanks while looping through destination sheet

            sourceKey = GetSourceKey(destKey)
            If sourceKey = "" Then GoTo endFor                                  '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)
  endFor:
        Next i

        SrcWb.Close
        Application.StatusBar = "Copying is complete"


  DoEvents
  MyFile = Dir()

  End If

  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  'Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic
  ActiveSheet.DisplayPageBreaks = True

  End Sub

基本编码原则是

DRY

->不要重复；）

因此，将重新生成的代码移到

If

子句之外，只保留决定打开哪个文件的部分

像这样：

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 y 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
Application.ScreenUpdating = False

Dim answer As Integer
answer = MsgBox("If you want to select a specific file click Yes, if you want to go to default path, click No", vbYesNo + vbQuestion, "User Specified Path")

If answer = vbYes Then

    MyFile = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")

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


    Set SrcWb = Workbooks.Open(MyFile, UpdateLinks:=0)                                  'Opening the Source workbook


ElseIf answer = vbNo Then

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

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

End If

       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 endFor                                    'Ignoring blanks while looping through destination sheet

            sourceKey = GetSourceKey(destKey)
            If sourceKey = "" Then GoTo endFor                                  '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)
endFor:
        Next i

        SrcWb.Close
        Application.StatusBar = "Copying is complete"


  DoEvents
  MyFile = Dir()


  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  'Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic
  ActiveSheet.DisplayPageBreaks = True

  End Sub