Excel 2007 VBA複製匹配行循環

Question

我有一個工作簿，有一個「源」工作表和幾個目標工作表。基本上來說，源表包含我需要匹配並分配給團隊成員的信息。我已經得到了下面的代碼，它凍結了我的excel，就像它被困在一個永無止境的循環中。 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

如果細胞（X，Z）<> 「是」，X永遠不會被增加和細胞（X，1）<> vbNullString如果保持真實