VBAコードのこの特定のビットを小さくするにはどうすればよいですか？

Question

プロシージャがあまりにも大きいエラーを受信して​​いるところに達しました。これは、私のコードが非常に厄介であるためです。当該セクションは、以下：

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までのすべての方法を成長し、対応するコピー＆ペーストコマンドが各ステップで添加しますはしご。私の質問は、どうすればこれを短縮できますか？多くのコードが繰り返されているので、私はそれを短くしてよりエレガントにブートする方法を見つけることができるのだろうかと思っています。ありがとう！

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