將具有不同行號的行從不同的行復制到一張表

Question

我試圖創建一個宏以從A7開始將行從不同的行復制到「數據」表中。每張表中的行有所不同。它只是複製每張表中的第7行。這裏是我的代碼：

Sub Button1_Click() 

Worksheets("Data").Cells.ClearContents 

Dim x As Integer 
Dim y As Integer 
Dim ws1 As Worksheet 
Dim First As Integer 
Dim Last As Integer 
Dim i As Integer 

    Set ws1 = Worksheets("Data") 
    First = Worksheets("Data").Index 
    Last = Worksheets("Summary").Index 

    ws1.Range("A" & 1).Value = "Date" 
    ws1.Range("B" & 1).Value = "Equipment" 
    ws1.Range("C" & 1).Value = "Type" 
    ws1.Range("D" & 1).Value = "Qty/Hrs" 
    ws1.Range("E" & 1).Value = "Rate" 
    ws1.Range("F" & 1).Value = "Cost" 

     For i = (First + 1) To (Last - 1) 

     With Sheets(i) 

      MaxrOw = Cells(Rows.Count, "A").End(xlUp).Row 
      x = 7 

      Do Until .Range("A" & x).Value = "" 
      If Not .Range("I" & x).Value = "" Then 

       ws1.Range("A" & MaxrOw + 1).Value = .Range("G" & 2).Value 
       ws1.Range("B" & MaxrOw + 1).Value = .Range("A" & x).Value 
       ws1.Range("C" & MaxrOw + 1).Value = .Range("B" & x).Value 
       ws1.Range("D" & MaxrOw + 1).Value = .Range("G" & x).Value 
       ws1.Range("E" & MaxrOw + 1).Value = .Range("H" & x).Value 
       ws1.Range("F" & MaxrOw + 1).Value = .Range("I" & x).Value 

       x = x + 1 
      Else 
       x = x + 1 

      End If 

     Loop 

     End With 

     Next i 

     Columns("A:F").Sort key1:=Range("C1"), Order1:=xlAscending, Header:=xlYes 

End Sub 

在此先感謝。

Answer 1

Scott Craner已經修復了您的語法問題，但正如其他人所說的，您的代碼中存在一些低效率問題。看看這裏作爲起點https://msdn.microsoft.com/en-us/library/office/ff726673(v=office.14).aspx。

因此，對於您的代碼：

1. 通過工作指標的循環，不能依靠。例如，如果您移動了「數據」或「摘要」表（故意或錯誤），您可能會漏掉循環中的一些表。如果每個工作表都是你想要的工作表，那麼通過Worksheets循環收集和測試就更加可靠。
2. 無論何時讀寫工作表時，通常都可以更快地讀寫變量數組。特別是逐個單元地寫入是非常耗時的。
3. 對於每一行迭代，查找最後一行也是不必要的。更快會找到一次，然後每次你寫一行時簡單地加1。當然，更快的還是第二點。

下面的代碼解決了這三個問題。這不是最有效的內存，但它會很快。

Dim ws As Worksheet 
Dim dataSets As Collection 
Dim output() As Variant 
Dim dataValues(1) As Variant 
Dim d As Long 
Dim x As Long 
Dim v As Variant 

'Acquire the data from each sheet and aggregate the output array size 
Set dataSets = New Collection 
d = 2 
For Each ws In ThisWorkbook.Worksheets 
    If ws.Name <> "Data" And ws.Name <> "Summary" Then 
     dataValues(0) = ws.Range("G2").Value 
     dataValues(1) = ws.Range("A7", ws.Cells(ws.Rows.Count, "A").End(xlUp)).Resize(, 9).Value2 
     d = d + UBound(dataValues(1), 1) 
     dataSets.Add dataValues 
    End If 
Next 

'Redimension the output array 
ReDim output(1 To d, 1 To 6) 

'Populate the header 
output(1, 1) = "Date" 
output(1, 2) = "Equipment" 
output(1, 3) = "Type" 
output(1, 4) = "Qty/Hrs" 
output(1, 5) = "Rate" 
output(1, 6) = "Cost" 

'Populate the output array with values 
d = 2 
For Each v In dataSets 
    For x = 1 To UBound(v(1), 1) 
     output(d, 1) = v(0) 
     output(d, 2) = v(1)(x, 1) 
     output(d, 3) = v(1)(x, 2) 
     output(d, 4) = v(1)(x, 7) 
     output(d, 5) = v(1)(x, 8) 
     output(d, 6) = v(1)(x, 9) 
     d = d + 1 
    Next 
Next 

'Write the array 
ThisWorkbook.Worksheets("Data").Range("A1").Resize(UBound(output, 1), UBound(output, 2)).Value = output