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

如何缩短VBA代码的这一特定位置以使其更小？

2 个答案: