VBA循環與數組複製輸出

Question

我是新來使用數組（和一般的VBA），我試圖將一系列數組合併到一個模塊中，在單個工作簿的工作表中格式化SPSS語法輸出。下面是我的代碼，它可以工作，但是會複製找到的結果。我認爲這與我的循環順序有關，但我似乎無法弄清楚如何解決它。任何想法將不勝感激。

Sub FindValues() 

Call CreateSummary 

'This code will build the initial summary file 

    Dim ws As Excel.Worksheet 

    'Application.ScreenUpdating = False 

    MsgBox ("It will take a moment for data to appear, please be patient if data does not immediately appear") 

    Dim LastRow As Long 
    Dim i As Integer 
    Dim i2 As Integer 
    Dim x As Integer 
    Dim y As Integer 
    Dim CopiedRows As Integer 
    Dim LocationA(4) As String 
    Dim LocationB(4) As String 
    Dim LocationC(4) As String 
    Dim LocationD(4) As String 
    Dim VariableA(4) As Integer 
    Dim VariableB(4) As Integer 
    Dim ColumnA(4) As String 
    Dim ColumnB(4) As String 
    Dim n As Long 

    'Find DateTime Info 
    LocationA(1) = "Date_Time" 
    LocationB(1) = "Quarter" 
    LocationC(1) = "N" 
    LocationD(1) = "Minimum" 
    VariableA(1) = 1 
    VariableB(1) = 1 
    ColumnA(1) = "B" 
    ColumnB(1) = "C" 

    LocationA(2) = "Dur*" 
    LocationB(2) = "Methodology_ID" 
    LocationC(2) = "Mean" 
    LocationD(2) = "N" 
    VariableA(2) = 1 
    VariableB(2) = 1 
    ColumnA(2) = "C" 
    ColumnB(2) = "D" 

    LocationA(3) = "WebTimeout" 
    LocationB(3) = "Methodology_ID" 
    LocationC(3) = "Mean" 
    LocationD(3) = "N" 
    VariableA(3) = 1 
    VariableB(3) = 1 
    ColumnA(3) = "C" 
    ColumnB(3) = "D" 

    'LocationA(4) = "Crosstabulation" 
    'LocationB(4) = "Quarter" 
    'LocationC(4) = "N" 
    'LocationD(4) = "Minimum" 
    'VariableA(4) = 1 

    'Find OSAT Data 
    'LocationA(2) = "*Report*" 
    'LocationB(2) = "*CallMonth*" 
    'LocationC(2) = "Mean*" 
    'LocationD(2) = "*Overall*" 
    'VariableA(2) = 2 

    For Each ws In Application.ThisWorkbook.Worksheets 
    'Starting row 
    i = 1 
    'Find LastRow 
    LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row 

    If ws.Name <> "Run Macros" Then 

     Do While i <= LastRow 
      For x = 1 To 3 

      If ws.Range("A" & i).Value Like LocationA(x) And ws.Range("A" & i + 1).Value Like LocationB(x) And ws.Range(ColumnA(x) & i + VariableA(x)).Value Like LocationC(x) And ws.Range(ColumnB(x) & i + VariableB(x)).Value Like LocationD(x) Then 
      CopiedRows = 0 
      i2 = i 

       Do While ws.Range("A" & i2 + 1).Borders(xlEdgeLeft).LineStyle = 1 And ws.Range("A" & i2 + 1).Borders(xlEdgeLeft).Weight = 4 
       i2 = i2 + 1 
       CopiedRows = CopiedRows + 1 
       Loop 
       n = Sheets("Summary").Cells(Rows.Count, "A").End(xlUp).Row + 4 
       ws.Rows(i & ":" & i + CopiedRows).Copy Sheets("Summary").Range("A" & n) 
      On Error Resume Next 
      End If 
      Next x 
      i = i + 1 
     Loop 
    End If 
    Next 

    'Application.ScreenUpdating = True 

End Sub 

Answer 1

如果有人想重新使用此代碼這個工程......

For x = 1 To 3 Step 1 
      For Each ws In Application.ThisWorkbook.Worksheets 
       'Starting row 
       i = 1 
       'Find LastRow 
       LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row 
       Do While i <= LastRow 
        If ws.Name <> "Run Macros" Or ws.Name <> "Summary" Then 
        If ws.Range("A" & i).Value Like LocationA(x) And ws.Range("A" & i + 1).Value Like LocationB(x) And ws.Range(ColumnA(x) & i + VariableA(x)).Value Like LocationC(x) And ws.Range(ColumnB(x) & i + VariableB(x)).Value Like LocationD(x) Then 
         CopiedRows = 0 
         i2 = i 
         Do While ws.Range("A" & i2 + 1).Borders(xlEdgeLeft).LineStyle = 1 And ws.Range("A" & i2 + 1).Borders(xlEdgeLeft).Weight = 4 
         i2 = i2 + 1 
        CopiedRows = CopiedRows + 1 
        Loop 
         n = Sheets("Summary").Cells(Rows.Count, "A").End(xlUp).Row + 4 
         ws.Rows(i & ":" & i + CopiedRows).Copy Sheets("Summary").Range("A" & n) 
         Exit For 
         On Error Resume Next 
        End If 
        End If 
       i = i + 1 
       Loop 
      Next 
     Next x