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,