我有一个带有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
答案 0 :(得分:1)
基本编码原则是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