Question

我有一个包含一个“源”工作表和几个目标表的工作簿。本质上，源表包含我需要匹配和拆分给团队成员的信息。我有以下代码冻结我的优点，就像它陷入了永无止境的循环。 VBA存在于源工作表的VBA上。

Sub SearchForString()

Dim ws As Worksheet
Dim x As Integer
Dim y As Integer
Dim z as Integer

x = 1
y = 1
z = 4 'in this case we are looking at column D as the last non-criteria column


For Each ws In Worksheets(Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6", "Sheet7"))
    x = 1 'setting back to row 1 to grab headers
    y = 1
    ws.UsedRange.ClearContents
    Worksheets(ws.Name).Cells(y, 1) = Cells(x, 1)
    Worksheets(ws.Name).Cells(y, 1).Font.Bold = True
    Worksheets(ws.Name).Cells(y, 2) = Cells(x, 2)
    Worksheets(ws.Name).Cells(y, 2).Font.Bold = True
    Worksheets(ws.Name).Cells(y, 3) = Cells(x, 3)
    Worksheets(ws.Name).Cells(y, 3).Font.Bold = True
    Worksheets(ws.Name).Cells(y, 4) = Cells(x, 4)
    Worksheets(ws.Name).Cells(y, 4).Font.Bold = True

    'begin the copy loop
    x = 2 'setting forward to the first row to start evaluating for copy
    y = 2
    z = z + 1 'increments along the columns we are matching in the array

    Do while Cells(x, 1) <> vbNullString  'make sure we have an active row
      If Cells(x, z) = "Yes" Then  ' looks for row plus column for match

        Do While Worksheets(ws.Name).Cells(y, 2) <> vbNullString
          y = y + 1  'setting the row to start pasting
        Loop

        Worksheets(ws.Name).Cells(y, 1) = Cells(x, 1)
        Worksheets(ws.Name).Cells(y, 2) = Cells(x, 2)
        Worksheets(ws.Name).Cells(y, 3) = Cells(x, 3)
        Worksheets(ws.Name).Cells(y, 4) = Cells(x, 4)   
        x = x + 1  'increment to next row
      End If
    Loop

Next ws

End Sub

我无法发现将它固定在一个无限循环中的东西，就像它似乎存在一样。对任何人都有什么明显的东西吗？

Answer 1

如果Cells（x，z）＆lt;＆gt; ＆＃34;是＆＃34;，x永远不会增加，而单元格（x，1）＆lt;＆gt; vbNullString保持为真

Excel 2007 VBA复制匹配行循环

1 个答案: