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，

VBA复制并粘贴仅复制第一行

2 个答案: