Question

我有一个带有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

Answer 1

基本编码原则是DRY - ＆gt;不要重复自己;）

所以将重用的代码移到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

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

1 个答案: