我怎样才能缩短这个特定的VBA代码，使其更小？

我已经达到了我收到一个程序太大的错误，这是因为我的代码是非常笨重的。 有关部分如下：

If patientsperrespondentpertimepoint = 1 Then Sheets("Work").Select Range("D2:D" & patientprofiles + 1).Select Selection.Copy Sheets("Output").Select Range("B2").Select Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True ElseIf patientsperrespondentpertimepoint = 2 Then Sheets("Work").Select Range("D2:D" & patientprofiles + 1).Select Selection.Copy Sheets("Output").Select Range("B2").Select Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True Sheets("Work").Select Range("D" & patientprofiles + 2 & ":D" & 2 * patientprofiles + 1).Select Selection.Copy Sheets("Output").Select Range("B3").Select Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True ElseIf patientsperrespondentpertimepoint = 3 Then Sheets("Work").Select Range("D2:D" & patientprofiles + 1).Select Selection.Copy Sheets("Output").Select Range("B2").Select Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True Sheets("Work").Select Range("D" & patientprofiles + 2 & ":D" & 2 * patientprofiles + 1).Select Selection.Copy Sheets("Output").Select Range("B3").Select Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True Sheets("Work").Select Range("D" & 2 * patientprofiles + 2 & ":D" & 3 * patientprofiles + 1).Select Selection.Copy Sheets("Output").Select Range("B4").Select Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True 

这样继续下去， patientsperrespondentpertimepoint应答时间点从3到4到5一直增加到12，并且在梯子的每一步添加相应的复制和粘贴命令。 我的问题是，我怎样才能缩短这个？ 有很多代码被重复，所以我想知道如果我能find一种方法，使其更短，更优雅的启动。 谢谢！

Answer 1

 Dim i As Long For i = 0 To patientsperrespondentpertimepoint - 1 Worksheets("Work").Range("D" & (i * patientprofiles + 2) & ":D" & ((i + 1) * patientprofiles + 1)).Copy Worksheets("Output").Range("B2").Offset(i, 0).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True Next 

Answer 2

尝试这个。 还有一些可以进行的优化，但是这给你一个什么使代码更简洁的概念…

 Sub Foo() Dim shtWork As Worksheet Dim shtOut As Worksheet 'I've qualified the workbook as ThisWorkbook, but you might want to be more specific if the sheets are in a different workbook Set shtWork = ThisWorkbook.Sheets("Work") Set shtOutput = ThisWorkbook.Sheets("Output") If patientsperrespondentpertimepoint = 1 Then shtWork.Range("D2:D" & patientprofiles + 1).Copy shtOut.Range("B2").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True ElseIf patientsperrespondentpertimepoint = 2 Then shtWork.Range("D2:D" & patientprofiles + 1).Copy shtOut.Range("B2").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True shtWork.Range("D" & patientprofiles + 2 & ":D" & 2 * patientprofiles + 1).Copy shtOut.Range("B3").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True ElseIf patientsperrespondentpertimepoint = 3 Then shtWork.Range("D2:D" & patientprofiles + 1).Copy shtOut.Range("B2").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True shtWork.Range("D" & patientprofiles + 2 & ":D" & 2 * patientprofiles + 1).Copy shtOut.Range("B3").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True shtWork.Range("D" & 2 * patientprofiles + 2 & ":D" & 3 * patientprofiles + 1).Copy shtOut.Range("B4").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True 'I've added a closing 'End If here End If End Sub