Wanting to copy from one sheet to another, based on values in one column-CodePudding

I have an estimate sheet and an invoice. I am trying to write code to search the units column ("L") in the estimate sheet. When a number is found, copy the description from a different column ("A") to the invoice sheet in a certain range. I am able to get the search to loop through column L and it can determine whether the number is >0. It will even copy the first description over to the invoice. But, it will not copy anything over beyond that. I am looking for help please. Here is my code thus far.

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

CodePudding user response：

You are pasting to same line in Invoice sheet in each iteration.

Replace your line:

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

with

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

CodePudding user response：

Write From Another Column If Criteria Met

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