如何从一张表中复制值，其中值从特定行开始

Question

我想从名为“价格表”的工作表中复制值，在该表中，我想从“第 10 行”开始复制的值，并且只应复制“D 列”和“F 列”。并将其粘贴到另一个名为“Sheet1”的工作表中。它应该从“第 25 行”开始粘贴值并粘贴在“H 列”和“I 列”下。

我想放置一个条件语句，我只想复制工作表“价格表”中“D列”中值大于“零”的行，并将其粘贴到“H”列下的“sheet1”中和从“第 25 行”开始的“I”列。

Private Sub CommandButton1_Click()

a = Worksheets("PRICE SCHEDULE").Cells(Rows.Count, 1).End(xlUp).Row

For I = 2 To a
    If Worksheets("PRICE SCHEDULE").Cells(I, 4).Value = ">0" Then
        Worksheets("PRICE SCHEDULE").Rows(I).Copy
        Worksheets("Sheet1").Activate

        b = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
        ActiveSheet.Paste

        Worksheets("PRICE SCHEDULE").Activate
    End If
Next

End Sub

我尝试这样做并传递了一个 msgbox 来查看结果，但它没有显示复制数据的结果。

请查看图片以便更好地理解。

Answer 1

我会为此任务使用过滤器，如下所示：

Sub tgr()

    Dim wb As Workbook
    Dim wsData As Worksheet
    Dim wsDest As Worksheet
    Dim rDest As Range

    Set wb = ActiveWorkbook
    Set wsData = wb.Worksheets("Price Schedule")
    Set wsDest = wb.Worksheets("Sheet1")
    Set rDest = wsDest.Cells(wsDest.Rows.Count, "H").End(xlUp).Offset(1)
    If rDest.Row < 25 Then Set rDest = wsDest.Range("H25")

    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    With wsData.Range("D9:F" & wsData.Cells(wsData.Rows.Count, "D").End(xlUp).Row)
        If .Row < 9 Then GoTo CleanExit     'No data
        .AutoFilter 1, ">0", xlFilterValues 'Filter on column D for values >0
        Intersect(.Worksheet.Range("D:D,F:F"), .Offset(1)).Copy 'Copy filtered values in columns D and F only
        rDest.PasteSpecial xlPasteValues    'Paste values only to destination
        .AutoFilter 'Clear filter
    End With

CleanExit:
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub

Answer 2

试试下面的代码：

Option Explicit

Private Sub CommandButton1_Click()

Dim LastRow As Long, i As Long, b As Long

With Worksheets("PRICE SCHEDULE")
    LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row

    For i = 10 To LastRow ' loop from row 10 and forward
        If .Range("D" & i).Value >= 0 Then
            ' first get the next empty row to paste
            b = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1

            ' copy column "D" to column "H"
            .Range("D" & i).Copy Destination:=Worksheets("Sheet1").Range("H" & b)
            ' copy column "F" to column "I"
            .Range("F" & i).Copy Destination:=Worksheets("Sheet1").Range("I" & b)
        End If
    Next
End With

End Sub