想要根據一列中的值從一張紙復制到另一張紙

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