Question

我想知道是否有人可以帮我缩短代码，因为我担心在添加其他代码后可能需要很长时间才能运行。我想做的将在下面解释：

我想复制说test2（注意间距意味着变量在他们自己的行和列上）</ p>

test1 1 2 1
test2 2 1 4
test3 1 1 1

复制后，我会将其粘贴到其他工作表上。

假设我有另一组结果说

test2 2 1 4
test3 3 9 8
test5 1 1 1

我想复制test2，但我的VBA编码不能，因为它仍然假设test2在第2行。

最后一种情况是，如果test2不可用，它将继续复制结果的其余部分并将其粘贴到其他工作表上。

我做了一些编码，确实运行并帮我解决了这个问题。谢谢！

Sub Macro1()

 iMaxRow = 6 ' or whatever the max is.
    'Don't make too large because this will slow down your code.

    ' Loop through columns and rows
    For iCol = 1 To 1 ' or however many columns you have
        For iRow = 1 To 1

        With Worksheets("Sheet3").Cells(iRow, iCol)
            ' Check that cell is not empty.
            If .Value = "Bin1" Then
                Range("A1:G1").Select
                Selection.Copy
                Sheets("sheet4").Select
                Range("A1").Select
                ActiveSheet.Paste
                Sheets("sheet3").Select
            ElseIf .Value = "Bin2" Then
                Range("A1:G1").Select
                Selection.Copy
                Sheets("sheet4").Select
                Range("A1").Select
                ActiveSheet.Paste
                Sheets("sheet3").Select
            ElseIf .Value = "Bin3" Then
               Range("A1:G1").Select
                Selection.Copy
                Sheets("sheet4").Select
                Range("A1").Select
                ActiveSheet.Paste
                Sheets("sheet3").Select
            ElseIf .Value = "Bin4" Then
                Range("A1:G1").Select
                Selection.Copy
                Sheets("sheet4").Select
                Range("A1").Select
                ActiveSheet.Paste
                Sheets("sheet3").Select
            ElseIf .Value = "Bin5" Then
                Range("A1:G1").Select
                Selection.Copy
                Sheets("sheet4").Select
                Range("A1").Select
                ActiveSheet.Paste
                Sheets("sheet3").Select
            ElseIf .Value = "Bin6" Then
                Range("A1:G1").Select
                Selection.Copy
                Sheets("sheet4").Select
                Range("A1").Select
                ActiveSheet.Paste
                Sheets("sheet3").Select
            End If



        End With

    Next iRow
    Next iCol

For iCol1 = 1 To 1 ' or however many columns you have
        For iRow1 = 1 To 2

        With Worksheets("Sheet3").Cells(iRow1, iCol1)
            ' Check that cell is not empty.

                If .Value = "Bin2" Then
                Range("A2:G2").Select
                Selection.Copy
                Sheets("sheet4").Select
                Range("A2").Select
                ActiveSheet.Paste
                Sheets("sheet3").Select
            ElseIf .Value = "Bin3" Then
                Range("A2:G2").Select
                Selection.Copy
                Sheets("sheet4").Select
                Range("A2").Select
                ActiveSheet.Paste
                Sheets("sheet3").Select
            ElseIf .Value = "Bin4" Then
               Range("A2:G2").Select
                Selection.Copy
                Sheets("sheet4").Select
                Range("A2").Select
                ActiveSheet.Paste
                Sheets("sheet3").Select
            ElseIf .Value = "Bin5" Then
               Range("A2:G2").Select
                Selection.Copy
                Sheets("sheet4").Select
                Range("A2").Select
                ActiveSheet.Paste
                Sheets("sheet3").Select
            ElseIf .Value = "Bin6" Then
                Range("A2:G2").Select
                Selection.Copy
                Sheets("sheet4").Select
                Range("A2").Select
                ActiveSheet.Paste
                Sheets("sheet3").Select
            End If

        End With

    Next iRow1
    Next iCol1

For iCol2 = 1 To 1 ' or however many columns you have
        For iRow2 = 1 To 3

        With Worksheets("Sheet3").Cells(iRow2, iCol2)
            ' Check that cell is not empty.

                If .Value = "Bin3" Then
                Range("A3:G3").Select
                Selection.Copy
                Sheets("sheet4").Select
                Range("A3").Select
                ActiveSheet.Paste
                Sheets("sheet3").Select
            ElseIf .Value = "Bin4" Then
               Range("A3:G3").Select
                Selection.Copy
                Sheets("sheet4").Select
                Range("A3").Select
                ActiveSheet.Paste
                Sheets("sheet3").Select
            ElseIf .Value = "Bin5" Then
                Range("A3:G3").Select
                Selection.Copy
                Sheets("sheet4").Select
                Range("A3").Select
                ActiveSheet.Paste
                Sheets("sheet3").Select
            ElseIf .Value = "Bin6" Then
                Range("A3:G3").Select
                Selection.Copy
                Sheets("sheet4").Select
                Range("A3").Select
                ActiveSheet.Paste
                Sheets("sheet3").Select
            End If

        End With

    Next iRow2
    Next iCol2

For iCol3 = 1 To 1 ' or however many columns you have
        For iRow3 = 1 To 4

        With Worksheets("Sheet3").Cells(iRow3, iCol3)
            ' Check that cell is not empty.

                If .Value = "Bin4" Then
                Range("A4:G4").Select
                Selection.Copy
                Sheets("sheet4").Select
                Range("A4").Select
                ActiveSheet.Paste
                Sheets("sheet3").Select
            ElseIf .Value = "Bin5" Then
                Range("A4:G4").Select
                Selection.Copy
                Sheets("sheet4").Select
                Range("A4").Select
                ActiveSheet.Paste
                Sheets("sheet3").Select
            ElseIf .Value = "Bin6" Then
                Range("A4:G4").Select
                Selection.Copy
                Sheets("sheet4").Select
                Range("A4").Select
                ActiveSheet.Paste
                Sheets("sheet3").Select
            End If

        End With

    Next iRow3
    Next iCol3

For iCol4 = 1 To 1 ' or however many columns you have
        For iRow4 = 1 To 5

        With Worksheets("Sheet3").Cells(iRow4, iCol4)
            ' Check that cell is not empty.

                If .Value = "Bin5" Then
                Range("A5:G5").Select
                Selection.Copy
                Sheets("sheet4").Select
                Range("A5").Select
                ActiveSheet.Paste
                Sheets("sheet3").Select
            ElseIf .Value = "Bin6" Then
                Range("A5:G5").Select
                Selection.Copy
                Sheets("sheet4").Select
                Range("A5").Select
                ActiveSheet.Paste
                Sheets("sheet3").Select
            End If

        End With

    Next iRow4
    Next iCol4

For iCol5 = 1 To 1 ' or however many columns you have
        For iRow5 = 1 To 6

        With Worksheets("Sheet3").Cells(iRow5, iCol5)
            ' Check that cell is not empty.

                If .Value = "Bin6" Then
                 Range("A6:G6").Select
                Selection.Copy
                Sheets("sheet4").Select
                Range("A6").Select
                ActiveSheet.Paste
                Sheets("sheet3").Select
            End If

        End With

    Next iRow5
    Next iCol5
Sheets("Sheet4").Select
Range("A1").Select

End Sub

Answer 1

我正在努力确定您的代码的作用。下面我指出一些简化和其他必要的改进，但是一旦我们清除了灌木丛，可能会有更多。

更改1

请使用Option Explicit并声明您的变量。这可以避免将拼写错误变量视为新的隐式声明。

更改2

请使用Application.ScreenUpdating = False。这可以避免在宏完成任务时重新绘制屏幕。由于工作表之间的所有切换，这对您的代码至关重要。我的代码不太重要，因为我不换页。

更改3

替换：

With Sheets("Sheet3")
  :
  Range("A1:G1").Select
  Selection.Copy
  Sheets("sheet4").Select
  Range("A1").Select
  ActiveSheet.Paste
  Sheets("sheet3").Select
  :
End With

由：

With Sheets("Sheet3")
  :
  .Range("A1:G1").Copy Destination:=Worksheets("Sheet4").Range("A1")
  :
End With

这可以避免切换纸张，这是最浪费时间。

更改4

对于每个If-ElseIf-ElseIf-EndIf，您执行相同的副本。所以：

If .Value = "Bin1" Or .Value = "Bin2" Or .Value = "Bin3" _
   .Value = "Bin4" Or .Value = "Bin5"                   Then

会有同样的效果。

到目前为止

摘要

我相信以下内容与您的第一个循环完全相同：

Option Explicit
Sub Macro1()
  Dim iCol As Long
  Dim iRow As Long
  Dim ValueCell as String

  With Sheets("Sheet3")
    For iCol = 1 To 1
      For iRow = 1 To 1
        ValueCell = .Cells(iRow, iCol).Value
        If ValueCell = "Bin1" Or ValueCell = "Bin2" Or ValueCell = "Bin3" Or _
           ValueCell = "Bin4" Or ValueCell = "Bin5"                   Then
         .Range("A1:G1").Copy Destination:=Worksheets("Sheet4").Range("A1")
        End If
      Next
    Next
  End With

End Sub

可能的进一步更改

循环真的是独立的吗？对我来说，看起来好像你可以把它们合并成一个循环。

为回应评论而添加了新栏目

考虑你问题中的代码：

你有六个双循环。
在每种情况下，外部循环都是For iCol = 1 to 1。也就是说，您只检查列“A”，尽管您暗示如果代码更快，您将检查更多列。
内部循环为For iRow = 1 to №。 №在第一个循环中为1，在第二个循环中为2，在第六个循环中为6。如果代码更快，你暗示你会检查更多的行。
每个循环的动作取决于№。

显示№行动效果的表格：

Value
 of №   Cells examined   Values checked for   Range moved
   1    A1               "Bin1" ... "Bin6"    A1:G1
   2    A1, A2           "Bin2" ... "Bin6"    A2:G2
   3    A1, A2, A3       "Bin3" ... "Bin6"    A3:G3
   4    A1, A2, ... A4   "Bin4" ... "Bin6"    A4:G4
   5    A1, A2, ... A5   "Bin5", "Bin6"       A5:G5
   6    A1, A2, ... A6   "Bin6"               A6:G6

也就是说，在双循环№中，检查单元格A1到A№，检查值“Bin№”到“Bin6”，如果找到，则将Sheets("Sheet3").Range("A№:G№")复制到Sheets("Sheet4").Range("A№)。

在文本和示例数据中，您引用“text2”而不是“Bin2”。我不明白你想做什么。下面，我将介绍一些可以帮助您创建所需代码的VBA。如果没有，你将不得不在你的问题中添加一个新的部分，用英语解释你想要做什么。

新语法1

考虑：

For iRow = 1 to 6
    :
  .Range("A6:G6").Copy Destination:=Worksheets("Sheet4").Range("A6")
    :
Next

"A6:G6"和"A6"是您可以在运行时构建的字符串。

现在考虑：

For iRow = 1 to iRowMax
    :
  .Range("A" & iRowMax & ":G" & iRowMax)).Copy _
                         Destination:=Worksheets("Sheet4").Range("A" & iRowMax)
    :
Next

根据iRowMax的值，这给出了：

iRow    Statement    
  1     .Range("A1:G1")).Copy Destination:=Worksheets("Sheet4").Range("A1")
  2     .Range("A2:G2")).Copy Destination:=Worksheets("Sheet4").Range("A2")
  3     .Range("A3:G3")).Copy Destination:=Worksheets("Sheet4").Range("A3")

新语法2

在运行时更改范围的另一种方法是替换：

.Range(string)

与

.Range(.Cells(RowTop,ColLeft),.Cells(RowBottom,ColRight))

使用此语法，您可以轻松指定所需大小的矩形。

新语法3

考虑：

For i = 1 to 5
  If this(i) = that Then
    Do something fixed
    Exit For
  End If
Next
' Exit For statement jumps to here

在这个循环中，我正在测试五个值。如果有任何匹配，我会做点什么。如果我在第一个值上得到匹配，我不需要检查其他值。 Exit For允许我跳出For-Loop。如果存在嵌套的For-Loops，Exit For仅退出内循环

新语法4

"Bin1"，"Bin2"等也可以在运行时创建。

iRowMax = 4
For iRow = 1 to iRowMax
  For iBin = iRowMax to 6
    If ValueCell = "Bin" & iBin Then
      ' Move Range
      Exit For
    End If 
  Next
  ' Exit For statement jumps to here
Next

iRow = 4时，内部For-Loop将iBin设置为4,5和6.这将"Bin" & iBin设置为"Bin4"，"Bin5"和"Bin6"。

所以：

  For BinNum = iRowMax to 6
    If ValueCell = "Bin" & BinNum Then
      ' Move Range
      Exit For
    End If 
  Next

与：

相同

  If ValueCell = "Bin4" Or ValueCell = "Bin5" Or ValueCell = "Bin6" Then
    ' Move Range
  End If

这个新代码比原版更复杂，更难理解，但它可能就是你需要的。

<强>摘要

我已经向您展示了根据iRow的价值改变发生情况的不同方法。我希望其中一个能让你建立你想要的例程。

我没有对它进行过测试，但我认为这与原始代码中的所有六个循环相同：

Option Explicit
Sub Macro1()
  Dim iBin as Long
  Dim iCol As Long
  Dim iRow As Long
  Dim iRowMax as Long
  Dim ValueCell as String

  Application.ScreenUpdating = False

  With Sheets("Sheet3")
    For iRowMax = 1 to 6
      For iCol = 1 To 1     ' This could be replaced by iCol = 1 at the top
        For iRow = 1 To iRowMax
          ValueCell = .Cells(iRow, iCol).Value
          For iBin = iRowMax to 6
            If ValueCell = "Bin" & iBin Then
              .Range("A" & iRowMax & ":G" & iRowMax)).Copy _
                      Destination:=Worksheets("Sheet4").Range("A" & iRowMax)
            End If
          Next iBin
        Next iRow
     Next iCol
  End With
End Sub

注意：仅删除所有Select语句会使此代码比您的代码更快。其他更改使它更小，更慢，因为我有两个额外的For-Loops，我在运行时构建字符串。

将结果列复制并粘贴到另一个电子表格中

1 个答案: