Export Cells that aren't blanks to new Workbook with SaveAs Dialog

[Foolzrailer]

Hello

I'm trying to write a bit of VBA code that looks at the cells in Y2:AF2882 and exports all the values that aren't blank (blanks should be based on the data in Z2:AF2882) to a new Workbook. I would like to name and choose location of the new Workbook in the FileDialog prompt.

For instance there might only be data in Y2:AF242, then only that data should be exported to a new Workbook. In the sample below there is a time stamp in Y but no more data in Z:AF, so that is the cutoff basically.

Sample data, data in Column Y (TIME) is a formula, I don't want the formula in the export, but I do want it to show the correct time in the export:

Y	Z	AA	AB	AC	AD	AE	AF
TIME	T1	T2	T5	T10	T20	T50	T100
01-01-2021 00:00​	0,374107​	0,431733​	0,513049​	0,57789​	0,645042​	0,735833​	0,804499​
01-01-2021 00:01​	0,376484​	0,434559​	0,516533​	0,581927​	0,649682​	0,741356​	0,810762​
01-01-2021 00:02​	0,378898​	0,437429​	0,520073​	0,586028​	0,654397​	0,74697​	0,81713​
=IF(Y5<$Y$3+TIME(0;$S$12;0)-TIME(0;1;0);Y5+TIME(0;$T$12;0);"")​	0,381348​	0,440344​	0,523668​	0,590195​	0,659189​	0,752679​	0,823609​
=IF(Y6<$Y$3+TIME(0;$S$12;0)-TIME(0;1;0);Y6+TIME(0;$T$12;0);"")​	0,383836​	0,443304​	0,527321​	0,594429​	0,66406​	0,758485​	0,8302​
01-01-2021 00:05​

Sub SaveXLSX()
  Dim Filename As Variant
  Dim Wb As Workbook
  Dim Source As Range, Dest As Range
  
    With Sheets("SVK stationer")
    'Refer to the data cells
    Set Source = .Range("Y2:AF2882")
    'Build the file name (same result as your code, just to show another way)
    End With
  'Ask the user
  Filename = Application.GetSaveAsFilename(Filename, "Excelfile (*.xlsx), *.xlsx")
  'Aborted?
  If VarType(Filename) = vbBoolean Then Exit Sub
  'Create a new file
  Set Wb = Workbooks.Add(xlWBATWorksheet)
  'Refer to the destination cell
  Set Dest = Wb.Sheets(1).Range("A1")
 
  'Copy the cells
  Source.Copy Dest
  'Alternatively to remove the formulas if any:
  'Source.Copy
  'Dest.PasteSpecial xlPasteValuesAndNumberFormats
 
  'Save the file
  Wb.SaveAs Filename
End Sub

I got this far before I kinda got stumped, and I'm unsure how I would go about getting the correct time in the new Workbook, as well as only exporting the cells that I want.

 

[GWteB]

See if this works for you. Note the separate function that the main procedure depends on.

Sub SaveXLSX()

    'Ask the user
    Dim Filename As Variant
    Filename = Application.GetSaveAsFilename(Filename, "Excelfile (*.xlsx), *.xlsx")

    'Aborted?
    If Not VarType(Filename) = vbBoolean Then
    
        Application.ScreenUpdating = False

        ' determine where to cut off
        With ThisWorkbook.Sheets("SVK stationer")
            Dim sourceRng As Range
            Set sourceRng = .Range("Y2", LastPopulatedCell(.Range("Z:AF")))
        End With

        ' create a new workbook to be saved on disk
        Dim newSht As Worksheet
        Set newSht = Application.Workbooks.Add(xlWBATWorksheet).Sheets(1)

        ' determine size of destination range so the source range fits
        With sourceRng
            Dim destRng As Range
            Set destRng = newSht.Range("A1").Resize(.Rows.Count, .Columns.Count)
            ' copy only values
            destRng.Value = .Value
            destRng.EntireColumn.AutoFit
        End With

        'Save the new workbook
        newSht.Parent.SaveAs Filename

        Application.ScreenUpdating = True
    End If
End Sub


Public Function LastPopulatedCell(ByVal argRng As Range) As Range
    Dim x As Long, y As Long
    If Not argRng Is Nothing Then
        On Error Resume Next
        x = argRng.Find(What:="*", After:=argRng.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
        y = argRng.Find(What:="*", After:=argRng.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
        Set LastPopulatedCell = argRng.Parent.Cells(y, x)
        If Err.Number > 0 Then
            Set LastPopulatedCell = argRng.Cells(1)
            Err.Clear
        End If
    End If
End Function

 

[Foolzrailer]

This is absolutely brilliant. Thank you very much!

 

[GWteB]

You are welcome and thanks for the feedback