How can I shorten this particular bit of VBA code to make it smaller?

Question

I've reached the point where I'm receiving a procedure too large errors, and it's because my code is very clunky. The section in question follows:

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

This continues, and patientsperrespondentpertimepoint grows one by one from 3 to 4 to 5 all the way up to 12, and a corresponding copy and paste command is added at each step of the ladder. My question is, how can I shorten this? There's a lot of code being repeated, so I'm wondering if I can find a way to make it shorter, and more elegant to boot. Thanks!

See [How to avoid using Select in Excel VBA macros](http://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba-macros) for methods on getting away from relying on select and activate to accomplish your goals. — , Apr 04 '16 at 20:04
Read through [how to avoid `.Select`](http://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba-macros), this will get you pretty far. — BruceWayne, Apr 04 '16 at 20:04
@Jeeped Will do. Why is it so bad to rely on select and activate? — sarcasm24, Apr 04 '16 at 20:59

GSerg · Accepted Answer · 2016-04-04T20:37:57.377

3

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

edited Apr 04 '16 at 20:37

answered Apr 04 '16 at 20:21

GSerg

76,472
17
159
346

1

This works perfectly. Really impressive to replace hundreds of lines of code with 5 lines. Thanks! – sarcasm24 Apr 04 '16 at 20:53
Nice solution. You could eek out some performance by creating reference variables for the worksheets, and also by using the Cells method to refer more directly to the Target range, instead of Range(...).Offset(...) – ThunderFrame Apr 04 '16 at 23:31

score 1 · Answer 2 · answered Apr 04 '16 at 20:19

Try this. There are some more optimizations that could be made, but this gives you an idea of what makes code more concise...

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

How can I shorten this particular bit of VBA code to make it smaller?

2 Answers2