Question

我需要根据1个单元格中的数据将范围复制到新工作表我有100行数据。数据从第11行开始。

如果单元格E> = 13，则复制范围B11：E11至表格2 如果单元格E <= 12，则复制范围B11：E11至表3

Sheets1.Select
For n = 11 To 129
If Cells(n, 5) >= 13 Then
Range("B" & n, "E" & n).Copy sheets2.Range("B11")
Else
Range("B" & n, "E" & n).Copy sheet3.Range("B11")
End If
Next n

我做错了什么？

谢谢

修改
谢谢大家的帮助。这就是我现在所拥有的。

Sub ConditionalCopy()

  Dim ws1, ws2, ws3, ws4, ws5, ws6, ws7, ws As Worksheet
  Dim row1, row2, row3, row4, row5, row6, row7, row As Integer

  Set ws1 = Worksheets("1ST BROWN")
  Set ws2 = Worksheets("1ST BROWN NOTES")
  Set ws3 = Worksheets("KIDS BROWN NOTES")
  Set ws4 = Worksheets("2ND BROWN")
  Set ws5 = Worksheets("2ND BROWN NOTES")
  Set ws6 = Worksheets("3RD BROWN")
  Set ws7 = Worksheets("3RD BROWN NOTES")

  row2 = 10
  row3 = 10

  For row1 = 11 To 129
    If ws1.Cells(row1, 5).Value >= 13 Then
      Set ws = ws2
      row2 = row2 + 1
      row = row2
    Else
      Set ws = ws3
      row3 = row3 + 1
      row = row3
    End If

    ws.Range("B" & row & ":E" & row).Value = _
      ws1.Range("B" & row1 & ":E" & row1).Value

  Next row1

  row5 = 10

  For row4 = 11 To 129
    If ws4.Cells(row4, 5).Value >= 13 Then
      Set ws = ws5
      row5 = row5 + 1
      row = row5
    Else
      Set ws = ws3
      row3 = row3 + 1
      row = row3
    End If

    ws.Range("B" & row & ":E" & row).Value = _
      ws4.Range("B" & row4 & ":E" & row4).Value

  Next row4

  row7 = 10

  For row6 = 11 To 129
    If ws6.Cells(row6, 5).Value >= 13 Then
      Set ws = ws7
      row7 = row7 + 1
      row = row7
    Else
      Set ws = ws3
      row3 = row3 + 1
      row = row3
    End If

    ws.Range("B" & row & ":E" & row).Value = _
      ws6.Range("B" & row6 & ":E" & row6).Value

  Next row6


End Sub

Answer 1

看起来您的副本中的行已经硬编码了。我不确定你是否想要数据顺序（换句话说，第1页有100行，所以第2 + 3页应该总共100行，没有间隙），或者如果你想要数据在第1页的同一行。这个例子假设没有间隙。

Sub ConditionalCopy()

  Dim ws1, ws2, ws3, ws As Worksheet
  Dim row1, row2, row3, row As Integer

  Set ws1 = Sheets(1)
  Set ws2 = Sheets(2)
  Set ws3 = Sheets(3)

  row2 = 10
  row3 = 10

  For row1 = 11 To 129
    If ws1.Cells(row1, 5).Value >= 13 Then
      Set ws = ws2
      row2 = row2 + 1
      row = row2
    Else
      Set ws = ws3
      row3 = row3 + 1
      row = row3
    End If

    ws.Range("B" & row & ":E" & row).Value = _
      ws1.Range("B" & row1 & ":E" & row1).Value

  Next row1

End Sub

如果可能的话，我真的不鼓励选择/复制/粘贴方法。 VBA有更好的数据移动方式。在上面的示例中，我们从整个范围中获取值并将它们移动到另一个范围。

看看这是否与您的想法相近。

- 编辑 -

事实证明，数据就在那里！您只需向下滚动即可查看。

问题是它仍在移动数据行，即使没有“真实”数据要移动。您正在迭代第11行到第129行并复制，即使是空白。

我建议您根据学生的姓名对每个for循环进行短路。如果它是空白的，则退出循环。这应该允许“孩子”表上的名称是顺序的。

以下是一些可以执行此操作的片段：

对于“First Brown：”

For row1 = 11 To 129

  If ws1.Cells(row1, 4).Value = "" Then
    Exit For
  End If

“第二次布朗：”

For row4 = 11 To 129

  If ws4.Cells(row4, 4).Value = "" Then
    Exit For
  End If

“第三布朗：”

For row6 = 11 To 129

  If ws4.Cells(row6, 4).Value = "" Then
    Exit For
  End If

- 编辑10/18/2016 -

以下是使用相同代码对所有三张表执行此操作的代码的简化版本。我测试了它，它似乎也没有跳过线。

Sub ConditionalCopy()

  Dim source, destination, kids, ws As Worksheet
  Dim iteration, sRow, dRow, kRow, row As Integer

  Set kids = Worksheets("KIDS BROWN NOTES")
  kRow = 10

  For iteration = 1 To 3
    sRow = 10
    dRow = 10

    If iteration = 1 Then
      Set source = Worksheets("1ST BROWN")
      Set destination = Worksheets("1ST BROWN NOTES")
    ElseIf iteration = 2 Then
      Set source = Worksheets("2ND BROWN")
      Set destination = Worksheets("2ND BROWN NOTES")
    Else
      Set source = Worksheets("3RD BROWN")
      Set destination = Worksheets("3RD BROWN NOTES")
    End If

    For sRow = 11 To 129
      If source.Cells(sRow, 4).Value = "" Then
        Exit For
      End If

      If source.Cells(sRow, 5).Value >= 13 Then
        Set ws = destination
        dRow = dRow + 1
        row = dRow
      Else
        Set ws = kids
        kRow = kRow + 1
        row = kRow
      End If

      ws.Range("B" & row & ":E" & row).Value = _
          source.Range("B" & sRow & ":E" & sRow).Value
    Next sRow
  Next iteration

End Sub

- 编辑2 10/18/2016 -

关于Run_Before_Test我认为你想要一个稍微不同的方法。我建议你使用我最喜欢的结构之一，字典结构。您需要在Tools-＆gt; References中将其添加到VBA中，然后选中“Microsoft Scripting Runtime”旁边的复选框。一旦你这样做，你就可以访问字典并利用它的intellisense。

查看此代码是否有意义。您可能需要进行小的调整，但我认为阅读（和修改）很容易：

Sub RunBeforeTest()
  Dim BeltSheet As New Dictionary
  Dim RowNumbers As New Dictionary
  Dim master As ListObject
  Dim lr As ListRow
  Dim source, dest As Worksheet
  Dim row As Integer

  BeltSheet.Add "Jr. Black", Sheets("BLACK")
  BeltSheet.Add "1st Black", Sheets("BLACK")
  BeltSheet.Add "2nd Black", Sheets("BLACK")
  BeltSheet.Add "3rd Black", Sheets("BLACK")
  BeltSheet.Add "4th Black", Sheets("BLACK")
  BeltSheet.Add "5th Black", Sheets("BLACK")
  BeltSheet.Add "6th Black", Sheets("BLACK")
  BeltSheet.Add "1st Brown", Sheets("1ST BROWN")
  BeltSheet.Add "2nd Brown", Sheets("2ND BROWN")
  BeltSheet.Add "3rd Brown", Sheets("3RD BROWN")
  RowNumbers.Add Sheets("BLACK"), 11
  RowNumbers.Add Sheets("1ST BROWN"), 11
  RowNumbers.Add Sheets("2ND BROWN"), 11
  RowNumbers.Add Sheets("3RD BROWN"), 11

  Set master = Sheets("MASTER").ListObjects("Table2")
  For Each lr In master.ListRows
    If lr.Range(1, 1).Value = "" Then
      Exit For
    End If

    Set ws = BeltSheet(lr.Range(1, 1).Value)
    row = RowNumbers(ws)

    ws.Range("B" & row & ":E" & row).Value = lr.Range.Value

    RowNumbers(ws) = row + 1
  Next lr
End Sub

另外，直到我看到这些表格实际上正在使用表格的代码之前我才知道！这使得它变得如此简单。原始解决方案也可以重新设计，以利用表结构。

Answer 2

应该是Cells（n，5）.Value

Sheets1.Select
For n = 11 To 129
If Cells(n, 5).Value >= 13 Then
Range("B" & n, "E" & n).Copy sheets2.Range("B11")
Else
Range("B" & n, "E" & n).Copy sheet3.Range("B11")
End If
Next n

如果单元格为＆lt; = value

2 个答案: