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