想要根据一列中的值从一张纸复制到另一张纸

Question

我有估价单和发票。 我正在尝试编写代码来搜索估算表中的单位列（“L”）。 找到数字后，将不同列（“A”）中的描述复制到特定范围内的发票表中。 我能够让搜索循环遍历 L 列，它可以确定数字是否大于 0。 它甚至会将第一个描述复制到发票上。 但是，除此之外它不会复制任何内容。 我正在寻求帮助。 到目前为止，这是我的代码。

Sub CopyToInvoice()
    Dim rng As Range
    Dim i As Long
    Dim a As Long
    Dim rng_dest As Range
    Application.ScreenUpdating = False
    i = 1
    Set rng_dest = Sheets("Estimate").Range("L5")
    'Find first cell with value in column L on sheet Estimate
    Range("L5").Select
    Do Until WorksheetFunction.CountA(rng_dest.Rows(i)) = 100
    i = i + 1
    Set rng = Sheets("Invoice").Range("C22:C36")
    'Copy rows containing values to sheet Invoice
    For a = 1 To rng.Rows.Count
      If ActiveCell.Value > 0 Then
       Sheets("Estimate").Range("A5").Copy Sheets("Invoice").Range("C22")
      End If
        'Step down 1 row from present location
       ActiveCell.Offset(1, 0).Select
       i = i + 1
     Next a
  Application.ScreenUpdating = True
  Loop
End Sub

Answer 1

您将在每次迭代中粘贴到发票表中的同一行。

替换你的行：

Sheets("Estimate").Range("A5").Copy Sheets("Invoice").Range("C22")

和

Sheets("Estimate").Range("A" & 4 + a).Copy Sheets("Invoice").Range("C" & 21 + a)

Answer 2

如果满足条件，则从另一列写入

Option Explicit

Sub CopyToInvoice()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    Dim sws As Worksheet: Set sws = wb.Worksheets("Estimate")
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "L").End(xlUp).Row
    If slRow < 5 Then Exit Sub ' no data in column range
    
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Worksheets("Invoice")
    Dim dCell As Range: Set dCell = dws.Range("C22")
    
    Application.ScreenUpdating = False
    
    Dim r As Long
    
    For r = 5 To slRow ' rows in 'L'
        If IsNumeric(sws.Cells(r, "L").Value) Then ' numeric
            If sws.Cells(r, "L").Value > 0 Then ' check 'L>0'
                dCell.Value = sws.Cells(r, "A").Value ' write 'A' to destination
                Set dCell = dCell.Offset(1) ' next destination
            'Else ' L <= 0
            End If
        'Else ' not numeric
        End If
    Next r
    
    Application.ScreenUpdating = True

    MsgBox "Data copied.", vbInformation

End Sub