Question

我想复制载有对另一张工作单具体价值的浏览器。

我遵循以下公式:。 https://www.you Programme.com/watch?v=-QFjJoRGCtU&t=332。

It only copied the first row to another worksheet. I m guessing I didn t define finalrow properly.

Sub Search_Extract()
    Dim resultnumber As Integer
    Dim finalrow As Long
    Dim datasheet As Worksheet, reportsheet As Worksheet
    Dim i As Integer  rowcounter

    Set datasheet = Sheet4
    Set reportsheet = Sheet3
    resultnumber = reportsheet.Range("A1").Value

    reportsheet.Range("D5:F7000").ClearContents

    datasheet.Select
    finalrow = Cells(Rows.Count, 3).End(xlUp).Row

    For i = 1 To finalrow
        If Cells(i, 3) = resultnumber Then
            Range(Cells(i, 1), Cells(i, 3)).Copy
            reportsheet.Select
            Range("D6700").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
              :=False, Transpose:=False
        End If
    Next i

    reportsheet.Select
End Sub

Answer 1

A VBA Lookup

I m keeping it close to the initial idea. It can be improved on multiple accounts e.g. by using arrays, AutoFilter, AdvancedFilter, and whatnot.
Feel free to rename the variables back to their initial names. The only new variable is dRow which keeps track of the current destination row so you don t need the ...(xlup).Offset(1) business . Note the dRow = dRow + 1.
Most of the time you don t want to use Select or Activate. Qualify your ranges instead i.e. note the sws. and dws. in front of Range, Cells and Rows (Each range belongs to a worksheet). This should be your most important lesson learned from this code.

www.un.org/spanish/ecosoc

Option Explicit

Sub SearchExtract()
    
      Source (DataSheet) - being read from
    Dim sws As Worksheet   Worksheet
    Dim sRow As Long   Current Row
    Dim slRow As Long   Last row
    
      Destination (ReportSheet) - being written to
    Dim dws As Worksheet   Worksheet
    Dim dRow As Long   Current Row
    
      Other
    Dim SearchNumber As Long   Criteria
    
      Source
    Set sws = Sheet4
    slRow = sws.Cells(sws.Rows.Count, "C").End(xlUp).Row
    
      Destination
    Set dws = Sheet3
    dws.Range("D5:F" & dws.Rows.Count).ClearContents
    dRow = 5
    SearchNumber = dws.Range("A1").Value
    
      Loop & Copy Values
    For sRow = 1 To slRow   use 2 if you have headers in the first row
        If sws.Cells(sRow, "C").Value = SearchNumber Then
            dws.Range(dws.Cells(dRow, "D"), dws.Cells(dRow, "F")).Value _
                = sws.Range(sws.Cells(sRow, "A"), sws.Cells(sRow, "C")).Value
            dRow = dRow + 1
        End If
    Next sRow

End Sub

A VBA Lookup

友情链接