VBA複製並粘貼只複製第一行

Question

我希望你一切都好。

我正在嘗試使用下面的代碼將不同產品的訂單添加到一起。但只有D列中值大於0的產品。不幸的是，儘管代碼出於某種原因只複製範圍的第一行，即使有其他行符合條件。誰能幫忙？

Sub ADDTOORDERS() 
Dim Sh As Worksheet, C As Worksheet, Last As Long 
Set Sh = Sheets("Menu") 
Set C = Sheets("LensOrder") 
With Sh 
Last = .Cells(Rows.Count, 2).End(xlUp).Row 
    .Range("B7:D" & Last).AutoFilter Field:=2, Criteria1:=">0", Operator:=xlAnd 
    .Range("B7:D" & Last).SpecialCells(xlCellTypeVisible).Copy 
    C.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues) 
    Sheets("Menu").Range("C3").Select 
    .Range("B7:D" & Last).AutoFilter 
End With 
End Sub 

Answer 1

只做了1次更改。檢查這個。最後一排的東西。

Sub ADDTOORDERS() 
Dim Sh As Worksheet, C As Worksheet, Last As Long 
Set Sh = Sheets("Menu") 
Set C = Sheets("LensOrder") 
With Sh 

.Range("B7:D" & Last).AutoFilter Field:=2, Criteria1:=">0", Operator:=xlAnd 
Last = .range("B500000").end(xlup).row 
.Range("B7:D" & Last).SpecialCells(xlCellTypeVisible).Copy 
C.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues) 
Sheets("Menu").Range("C3").Select 
.Range("B7:D" & Last).AutoFilter 
End With 
End Sub 

Answer 2

與您的代碼的問題是，你要複製產生的範圍，但是這個範圍內有幾個方面，因此它只是複製第一個區域。 在這種情況下工作的方法之一是將結果範圍傳遞到數組中，然後將數組發佈到期望的範圍內。

該解決方案假定所述報頭是在第6行

嘗試下面的代碼：

Option Base 1 'This must be at the top of the module 

Sub Add_Orders() 
Dim wshSrc As Worksheet, wshTrg As Worksheet 
Dim rCpy As Range, aCpy() As Variant 
Dim rArea As Range, rRow As Range 
Dim lRowLst As Long, lRow As Long 
    With ThisWorkbook 
     Set wshSrc = .Worksheets("Menu") 
     Set wshTrg = .Worksheets("LensOrder") 
    End With 

    lRowLst = wshSrc.Cells(wshSrc.Rows.Count, 2).End(xlUp).Row 
'' With wshSrc.Range("B7:D" & lRowLst) 'The filter should always include the header - Replacing this line  
    With wshSrc.Range("B6:D" & lRowLst) 'With this line 
     ReDim Preserve aCpy(.Rows.Count) 
     .AutoFilter Field:=3, Criteria1:=">0" 
     Set rCpy = .Rows(1).Offset(1).Resize(-1 + .Rows.Count).SpecialCells(xlCellTypeVisible) 'Use the offset and resize to exclude the header 
    End With 

    For Each rArea In rCpy.Areas 
     For Each rRow In rArea.Rows 
      lRow = 1 + lRow 
      aCpy(lRow) = rRow.Value2 
    Next: Next 
    ReDim Preserve aCpy(lRow) 
    aCpy = WorksheetFunction.Index(aCpy, 0, 0) 

    With wshTrg.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) 
     .Cells(1).Resize(UBound(aCpy), UBound(aCpy, 2)).Value = aCpy 
    End With 

    End Sub 

推薦閱讀以下的頁面，以獲得所述資源的更深入的瞭解使用：

For Each...Next Statement ， Option keyword， Range Object (Excel)，

Variables & Constants, With Statement,