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

 

[hobbes11]

Wonderful..............worked beautifully

I have more to ask; but too tired now, will do it tomorrow.

 

[Fluff]

Glad to help & thanks for the feedback

 

[Rick Rothstein]

[table="width: 500"]
[tr]
[td]

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

Application.ScreenUpdating = True
End Sub

[/td]
[/tr]
[/table]

@Fluff,

I want to draw your attention to the above snippet of code from your last posting and, in particular, to the...

On Error Resume Next

statement in it. While you do not need it in the above code, I am going to suggest you always place an...

On Error GoTo 0

statement after the statement the On Error Resume Next is protecting against in order to shut it off. The reason is because if you don't, that On Error statement will remain active even if you call out to other functions or subroutines. Here is a short demo of a possible situation where a program could be impacted greatly if On Error GoTo 0 is not used.

[table="width: 500"]
[tr]
	[td]Sub DemoNeedFor_GoTo_0()
  Dim ImportantValueForLaterCalculation As Double
  On Error Resume Next
  MsgBox 5 / 0
  [B][COLOR="#FF0000"]On Error GoTo 0[/COLOR][/B]
  ImportantValueForLaterCalculation = 10 + ImportantNumber
  '....
  '....
  MsgBox ImportantValueForLaterCalculation
End Sub

Function ImportantNumber() As Double
  Dim Divisor As Double
  ImportantNumber = 5 / Divisor
End Function[/td]
[/tr]
[/table]

Here I have placed an On Error GoTo 0 to protect the call out to the ImportantNumber function which has an error in it (because of "some error" in coding, the Divisor variable never got a non-zero value assigned to it. If you run the DemoNeedFor_GoTo_0 macro, the code will stop at the error inside the ImportantNumber function with a Division By Zero error so that you can track down the problem. Now, stop the currently "running' program, comment out the On Error GoTo 0 line of code and run the DemoNeedFor_GoTo_0 macro again. No one would ever know there was a problem with the ImportantValueForLaterCalculation variable unless the error produced by using 0 instead of the actual value that should have been returned by the function was so great that it was obvious from a simple observation. The reason for using On Error GoTo 0, even in situations like your posted code where its absence could not cause a problem, is to protect against future modifications where something is added that could be affected by its absence. Also, in a setting like this forum where many lurkers pick up programming techniques by copying code posted by the volunteers here, it protects those people against not realizing the problem I outlined above when they use On Error Resume Next in their own code away from the watchful eyes of the volunteers here.

 

[Fluff]

@Rick Rothstein
Many thanks for the advice.
Whilst I normally do include the On Error Goto 0. In this instance I simply took what the OP had posted & didn't bother putting it in as it was the end of the code.
But I take your point & will reset the error handle in future.
@hobbes11
Bearing in mind Rick' post#13. Here is my modified code

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
    On Error GoTo 0
Application.ScreenUpdating = True
End Sub

 

[hobbes11]

@Fluff

I have a button for save as pdf with the following code, but each time the save as window pops up and I click Cancel, a FALSE pdf will be saved. How can I disable this? And how to insert message to warn that if the same pdf filename exist, ok to overwrite?

Private Sub CmdSavetoPDF_Click()
'Save as PDF

Set InvSht = Sheets("Invoice")

FileNme = Application.GetSaveAsFilename("SampleInvoice" & " " & InvSht.Range("B9") & " " & InvSht.Range("E11") & " " & InvSht.Range("F11"))
On Error Resume Next
ActiveSheet.ExportAsFixedFormat xlTypePDF, FileNme, xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
End Sub

 

[Fluff]

How about

Private Sub CmdSavetoPDF_Click()
'Save as PDF
    Dim Filenme As String
    Dim InvSht As Worksheet
    Dim Ans As Long

Set InvSht = Sheets("Invoice")

Filenme = Application.GetSaveAsFilename("SampleInvoice" & " " & InvSht.Range("B9") & " " & InvSht.Range("E11") & " " & InvSht.Range("F11"))
If Filenme = "False" Then Exit Sub
If Dir(Filenme & ".pdf") <> "" Then
    Ans = MsgBox("File already exists.  Overwrite?", vbQuestion + vbYesNo, "Overwrite?")
    If Ans = vbNo Then Exit Sub
End If
InvSht.ExportAsFixedFormat xlTypePDF, Filenme, xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
End Sub

 

[hobbes11]

worked well and I modified slightly the below

Private Sub CmdSavetoPDF_Click()
'Save as PDF

Set InvSht = Sheets("Invoice")

Filenme = Application.GetSaveAsFilename("SampleInvoice" & " " & InvSht.Range("B9") & " " & InvSht.Range("E11") & " " & InvSht.Range("F11"))

'If user click cancel button not to save
If Filenme = "False" Then MsgBox "File not saved.", vbCritical: Exit Sub
If Dir(Filenme & ".pdf") <> "" Then
Ans = MsgBox("File already exists. Overwrite?", vbQuestion + vbYesNo, "Overwrite?")
If Ans = vbNo Then Exit Sub

End If
On Error Resume Next
InvSht.ExportAsFixedFormat xlTypePDF, Filenme, xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
End Sub

 

[Fluff]

Glad to help & thanks for the feedback

 

[hobbes11]

I need to clear the below data except formula in sheet(invoice) after I copy data into sheet(report). The sheet (invoice) will be protected by locking some of the cells for any editing. If i protect the worsheet there is no way my macro can run.

In Column B7 - manual data input
Column B9 - drop down list
Colum B10:B13 - Vlookup

In Column F10 - today () formula
Column F11 & F12 - drop down list
Column F14 - manual data input

In column A18:A41 - drop down list
column B18:B41 - Vlookup formula
column C18:C41 & D18:D41 - drop down list
column E & F - manual data input
column F49 - drop down list

In Row 44:48 - manual data input

My current code:

Private Sub CmdClearData_Click()
'Remove data but not formulaAns = MsgBox("Have you update to report?", vbYesNo + vbQuestion)
If Ans = vbNo Then Exit Sub
Sheet1.Range("B7:B13").SpecialCells(xlCellTypeConstants).ClearContents
Sheet1.Range("F11:F15").SpecialCells(xlCellTypeConstants).ClearContents
Sheet1.Range("A19:F41").SpecialCells(xlCellTypeConstants).ClearContents
Sheet1.Range("A44:F48").SpecialCells(xlCellTypeConstants).ClearContents
End Sub

 

[Fluff]

As this a completely different question, you need to start a new thread.