如果單元格 <= 值，則復制范圍

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循環。 如果為空，則退出循環。 這應該允許您的“孩子”表上的名稱是連續的。

以下是一些可以做到這一點的片段：

對於“第一布朗：”

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->References 在 VBA 中添加它，並在“Microsoft Scripting Runtime”旁邊打勾。 一旦你這樣做了，你就可以訪問字典並利用它的智能感知。

看看這段代碼是否有意義。 您可能需要稍作調整，但我認為閱讀（和修改）很容易：

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