CODEWITHSUNDEEP
vbaexcel
sarcasm24
sarcasm24

Reputation: 47

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

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!

Upvotes: 1

Views: 99

Answers (2)

GSerg
GSerg

Reputation: 78185

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

Upvotes: 3

ThunderFrame
ThunderFrame

Reputation: 9461

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

Upvotes: 1

Related Questions