How to Copy only cells with data VBA

[hobbes11]

Currently having a worksheet "invoice" with cell range of A19:F41 that will be able to input data and will be copying from worksheet "invoice" to worksheet "report" using the below code. But in between the range A19:F41, may have chances where some rows have no data in between some rows with data. How can I copy via VBA only rows with data to worksheet "report"? Thanks.

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("Report").Range("F:J")
' Find first empty row in columns F:J on sheet Report
Do Until WorksheetFunction.CountA(rng_dest.Rows(i)) = 0
i = i + 1
Loop
'Copy range A19:F41 on sheet Invoice to Variant array
Set rng = Sheets("Invoice").Range("A19:F41")
'Copy rows containing values to sheet Report
For a = 1 To rng.Rows.Count
If WorksheetFunction.CountA(rng.Rows(a)) <> 0 Then
rng_dest.Rows(i).Value = rng.Rows(a).Value

'Copy Date
Sheets("Report").Range("A" & i).Value = Sheets("Invoice").Range("F10").Value

'Copy Invoice Number
Sheets("Report").Range("B" & i).Value = Sheets("Invoice").Range("F11").Value

'Copy CRM Number
Sheets("Report").Range("C" & i).Value = Sheets("Invoice").Range("F12").Value

'Copy Account Manager
Sheets("Report").Range("D" & i).Value = Sheets("Invoice").Range("F13").Value

'Copy Company name
Sheets("Report").Range("E" & i).Value = Sheets("Invoice").Range("B9").Value

'Copy Comments
Sheets("Report").Range("K" & i).Value = Sheets("Invoice").Range("A44").Value

i = i + 1
End If
Next a

Application.ScreenUpdating = True
End Sub

 

[Fluff]

Hi & welcome to the board
Untested, but try

Sub CopyData()
    
    Dim Cnt As Long
    Dim DestRw As Long
    Dim InvSht As Worksheet
    
    Application.ScreenUpdating = False
    
    Set InvSht = Sheets("Invoice")
    With Sheets("Reports")
        DestRw = .Cells.Find("*", After:=.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
        'Copy rows containing values to sheet Report
        For Cnt = 19 To 41
            If WorksheetFunction.CountA(InvSht.Range("A" & Cnt).Resize(, 6)) <> 0 Then
                .Range("F" & DestRw).Resize(, 6).Value = InvSht.Range("A" & Cnt).Resize(, 6).Value
                'Copy Date
                .Range("A" & DestRw).Value = InvSht.Range("F10").Value
                
                'Copy Invoice Number
                .Range("B" & DestRw).Value = InvSht.Range("F11").Value
                
                'Copy CRM Number
                .Range("C" & DestRw).Value = InvSht.Range("F12").Value
                
                'Copy Account Manager
                .Range("D" & DestRw).Value = InvSht.Range("F13").Value
                
                'Copy Company name
                .Range("E" & DestRw).Value = InvSht.Range("B9").Value
                
                'Copy Comments
                .Range("K" & DestRw).Value = InvSht.Range("A44").Value
                
                DestRw = DestRw + 1
            End If
        Next Cnt
    End With

Application.ScreenUpdating = True
End Sub

You are trying to copy 6 columns (A to F) into 5 columns (F to J), so this copies 6 columns. Which can easily be changed.

 

[hobbes11]

tried but the same as my previous codes, there are still blanks rows that are being copied on the other worksheet

 

[Fluff]

Are the blank rows actually blank, or do they contain formulae that return"" ?

 

[hobbes11]

Worksheet "Invoice" : column A19:A41 - dropdown list
Worksheet "Invoice" : column B19:B41 - Vlookup
Worksheet "Invoice" : column C19:C41, D19:D41 - dropdown list
Worksheet "Invoice" : column E & F - normal cell

Above to copy into column F to J of worksheet "report"
Worksheet "report" column A = Worksheet "Invoice" F10 [which is formula of today()] for Date
Worksheet "report" column A = Worksheet "Invoice" F11 for Invoice No
Worksheet "report" column A = Worksheet "Invoice" F12 for CRM No
Worksheet "report" column A = Worksheet "Invoice" F13 for Account Mgr (dropdown list)
Worksheet "report" column A = Worksheet "Invoice" F14 for Courier Co (dropdown list)

Say if row 19 to 21 in worksheet "invoice" has data and that row 22 to 25 has no data and row 26 to 30 has data, how to copy only row 19 to 21 and row 26 to 30 to worksheet "report"?

 

[Fluff]

In that case try

Sub CopyData()
    
    Dim Cnt As Long
    Dim DestRw As Long
    Dim InvSht As Worksheet
    
    Application.ScreenUpdating = False
    
    Set InvSht = Sheets("Invoice")
    With Sheets("Reports")
        DestRw = .Cells.Find("*", After:=.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
        'Copy rows containing values to sheet Report
        For Cnt = 19 To 41
            If WorksheetFunction.CountBlank(InvSht.Range("A" & Cnt).Resize(, 6)) <> 6 Then
                .Range("F" & DestRw).Resize(, 6).Value = InvSht.Range("A" & Cnt).Resize(, 6).Value
                'Copy Date
                .Range("A" & DestRw).Value = InvSht.Range("F10").Value
                
                'Copy Invoice Number
                .Range("B" & DestRw).Value = InvSht.Range("F11").Value
                
                'Copy CRM Number
                .Range("C" & DestRw).Value = InvSht.Range("F12").Value
                
                'Copy Account Manager
                .Range("D" & DestRw).Value = InvSht.Range("F13").Value
                
                'Copy Company name
                .Range("E" & DestRw).Value = InvSht.Range("B9").Value
                
                'Copy Comments
                .Range("K" & DestRw).Value = InvSht.Range("A44").Value
                
                DestRw = DestRw + 1
            End If
        Next Cnt
    End With

Application.ScreenUpdating = True
End Sub

 

[hobbes11]

forget to include that 1 have a header in the worksheet "report"

 

[Fluff]

Change this line as shown in red

   DestRw = .Cells.Find("*", After:=.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious)[COLOR=#ff0000].Offset(1)[/COLOR].Row

 

[hobbes11]

now it works great.

Can i also ask how to save as pdf with predefined file name? I would like to have in the following format "SampleInvoice CRM No XXX Inv No YYY.

CRM No is in worksheet "Invoice" E12 and the No XXX is in F12
Inv No is in E13 and the No YYY is in F13

Currently using the following code

fName = Application.GetSaveAsFilename("SampleInvoice", "PDF Files (*.pdf), *.pdf")
If Ans = Cancel Then Exit Sub

On Error Resume Next
ActiveSheet.ExportAsFixedFormat xlTypePDF, fName, xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
End Sub

 

[Fluff]

How about

Sub CopyData()
    
    Dim Cnt As Long
    Dim DestRw As Long
    Dim InvSht As Worksheet
    Dim FileNme As String
    
    Application.ScreenUpdating = False
    
    Set InvSht = Sheets("Invoice")
    With Sheets("Reports")
        DestRw = .Cells.Find("*", After:=.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Offset(1).Row
    
        'Copy rows containing values to sheet Report
        For Cnt = 19 To 41
            If WorksheetFunction.CountBlank(InvSht.Range("A" & Cnt).Resize(, 6)) <> 6 Then
                .Range("F" & DestRw).Resize(, 6).Value = InvSht.Range("A" & Cnt).Resize(, 6).Value
                'Copy Date
                .Range("A" & DestRw).Value = InvSht.Range("F10").Value
                
                'Copy Invoice Number
                .Range("B" & DestRw).Value = InvSht.Range("F11").Value
                
                'Copy CRM Number
                .Range("C" & DestRw).Value = InvSht.Range("F12").Value
                
                'Copy Account Manager
                .Range("D" & DestRw).Value = InvSht.Range("F13").Value
                
                'Copy Company name
                .Range("E" & DestRw).Value = InvSht.Range("B9").Value
                
                'Copy Comments
                .Range("K" & DestRw).Value = InvSht.Range("A44").Value
                
                DestRw = DestRw + 1
            End If
        Next Cnt
    End With
    FileNme = "SampleInvoice " & InvSht.Range("E12") & " " & InvSht.Range("F12") & " " & InvSht.Range("E13") & " " & InvSht.Range("F13")
    On Error Resume Next
    ActiveSheet.ExportAsFixedFormat xlTypePDF, FileNme, xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

Application.ScreenUpdating = True
End Sub