我正在尝试通过使其可读性和简洁性来改进我的代码。在名为“ModTest”的模块和名为“ABC”的Sheet1中,我有以下内容:
Sub Questionnaire_1() ' ModTest
' do something
End Sub
Sub Questionnaire_2() ' ModTest
' do something
End Sub
Sub Questionnaire_3() ' ModTest
' do something
End Sub
Sub Questionnaire_4() ' ModTest
' do something
End Sub
Sub Math() ' ModTest
Dim Question As Integer
Question = Sheets("ABC").Range("G5").Value
If Question = 0 Then
' do something
Else
Select Case Question
Case Is = 1
Call Questionnaire_1
Case Is = 2
Call Questionnaire_1
Call Questionnaire_2
Case Is = 3
Call Questionnaire_1
Call Questionnaire_2
Call Questionnaire_3
Case Is = 4
Call Questionnaire_1
Call Questionnaire_2
Call Questionnaire_3
Call Questionnaire_4
End Select
End if
End Sub
但是,我不仅使用4份问卷,而且还有100份。我的意图是保留[ Sub Questionnaire_1 (...) Sub Questionnaire_100 ]这些行,但是通过消除Select Case来改进 for 命令中名为“Variable”的 Call 函数:
Sub Math()
Dim i, Question As Integer
Dim Variable as String
Question = Sheets("ABC").Range("G5").Value
If Question = 0 Then
' do something
Else
For i = 1 to Question
Variable = "Questionnaire_" & i
Call Variable
Next i
End if
End Sub
有人可以帮忙吗?我收到以下“VBA编译错误:预期的子,功能或属性”。
更多地思考一下,有可能通过另一个已经工作并避免使用100个潜艇的解决方案绕过Select Case和Call功能!通过新改进的跟进替换所有上述代码,如下:
Sub Questionnaire() ' ModTest
Dim i, f, g, Question As Integer
Question = Sheets("ABC").Range("G5").Value
If Question = 0 Then
' do something
Else
For i = 1 To Question
f = 18 + 2 * i
g = 19 + 2 * i
With Worksheets("ABC")
.Activate
.Range("V2").Value = i
.Range("X2").Value = "C"
.Range("G2").Select
Selection.Copy
.Range("G" & f).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Range("G3").Select
Selection.Copy
.Range("H" & g).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Range("X2").Value = "I"
.Range("L5").Select
Selection.Copy
.Range("L" & f).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Range("L6").Select
Selection.Copy
.Range("M" & g).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With
Next i
End If
End Sub
答案 0 :(得分:1)
我怀疑此代码可能适合您。请测试一下。
Option Explicit
Sub MathTest()
' 17 Dec 2017
' "Math" is a module of VBA. (For explanation, select and press F1)
' Its use as a procedure name may lead to unexpected results
Dim Ws As Worksheet
Dim i As Integer
Set Ws = Worksheets("ABC")
Application.ScreenUpdating = False
' this loop will not run if G5 < 1
For i = 1 To Int(Val(Ws.Range("G5").Value))
Questionnaire i, Ws
Next i
Application.ScreenUpdating = True
End Sub
Private Sub Questionnaire(ByVal Q As Integer, _
Ws As Worksheet)
' 17 Dec 2017
Const WhatsThis As Long = 18
' in the next line, all items are Variants except 'Question'
' Dim i, f, g, Question As Integer
Dim RowG As Long
Dim i As Long
RowG = WhatsThis + (2 * Q)
With Ws
.Range("V2").Value = Q
.Range("X2").Value = "C"
For i = 0 To 1
.Cells(RowG + i, "G").Value = .Cells(2 + i, "G").Value
Next i
End With
End Sub