VBA Code to Copy Non Blank Cells From one Sheet to Another

Question

I'm trying to write a VBA code to copy "Non-Blank" cells from one file to another. This code selects the last Non Blank row, but for the column it's copying A4 to AU . I'd like to copy columns A4 to LastcolumnNotblank and also last row. So basically copy A4 to (LastColumn)(LastRow)Not Blank

Would be really grateful if someone can help by editing the below code. Many thanks.

Sub Export_Template()

'' TPD

File_name = Application.GetSaveAsFilename(InitialFileName:="Engineering TPD", FileFilter:="Excel Files (*.xlsx), *.xlsx")

If File_name <> False Then

 Application.ScreenUpdating = False
 Application.DisplayAlerts = False

 LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row

 For i = 4 To LastRow
 If Left(ActiveSheet.Range("A" & i).Value, 1) <> "" Then lastactiverow = i
 Next i
   'MsgBox (lastactiverow)
    ActiveSheet.Range("A4:AU" & lastactiverow).Select
    Selection.Copy

Set NewBook = Workbooks.Add

ActiveSheet.Range("A1").PasteSpecial xlPasteValues

    ActiveWorkbook.SaveAs Filename:=File_name, FileFormat:=51

    ActiveWorkbook.Close (False)

End If
End Sub

Answer 1

1. I'm assuming that Col A is a good indicator of where to find your last used row
2. Also assuming that Row 1 is a good indicator of where to find your last used column
3. You need to change Sheet1 on 3rd line of code to the name of your sheet that has the data to be copied
4. You need to declare variables (Use Option Explicit )
5. Avoid .Select and .Selection at all costs (none are found in below solution)
6. You did not re-enable ScreenUpdating and DisplayAlerts
7. This is tested and works A-OK

---

Option Explicit

Sub Export_Template()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim NewBook As Workbook
Dim LRow As Long, LCol As Long
Dim FileName

FileName = Application.GetSaveAsFilename(InitialFileName:="Engineering TPD", FileFilter:="Excel Files (*.xlsx), *.xlsx")

If FileName <> False Then
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
        Set NewBook = Workbooks.Add
            LRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
            LCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

            ws.Range(ws.Cells(4, 1), ws.Cells(LRow, LCol)).Copy
            NewBook.Sheets(1).Range("A1").PasteSpecial xlPasteValues

        NewBook.SaveAs FileName:=FileName, FileFormat:=51
        NewBook.Close False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End If

End Sub

Answer 2

The code below will preserve your ActiveSheet range and use SaveAs to save to a new workbook with your specific name, without all the extra crap. It deletes all the sheets except for the ActivSheet , and deletes the first three rows, then using SaveAs to save to ThisWorkbook.Path . Your macro enabled workbook will not be changed. I actually don't like to use ActiveSheet due to the obvious problems, but since you were using it i kept it. I would suggest you use the name of the worksheet.

Sub SaveActiveSheetRangeAsNewWorkbook()
Dim ws As Worksheet

Application.DisplayAlerts = False

    With ThisWorkbook
        For Each ws In Application.ThisWorkbook.Worksheets
            If ws.Name <> ActiveSheet.Name Then
                ws.Delete
            End If
        Next

        .Sheets(1).Range("A1:A3").EntireRow.Delete
        .SaveAs Filename:="Engineering TPD", FileFormat:=xlOpenXMLWorkbook
    End With

Application.DisplayAlerts = True

End Sub