Appending data from two sheets and saving as new Workbook-CodePudding

I have a source workbook with two worksheets (ITDepExport and ITRepExport) that are populated using formulas. I am looking for some VBA to export any rows which are not blank and combine/append them in a destination workbook in a location chosen by the user.

The challenge is the destination workbook is uploaded to a web app and so it cannot contain any formulas, formatting etc. as these are seen as import rows, even though they are blank .PasteSpecial xlPasteValues does not seem to work.

Both ITDepExport and ITRepExport have the same headers (columns A:Q) and formulas to rows 500.

Does anyone have any clever ideas?

Edit: This is what I have tried so far:

This exports one of the sheets but includes the formulas, so does not import into the web app correctly.

Sub ITDepExport()
    Dim fName
    Sheets("ITDepExport").Copy
    With ActiveSheet
        .UsedRange.Copy
        .Cells(1, 1).PasteSpecial xlPasteValues
    End With
    Application.CutCopyMode = False
    fName = Application.GetSaveAsFilename(InitialFileName:="", FileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="Save As")
    With ActiveWorkbook
        .SaveAs FileName:=fName
        .Close False
    End With
End Sub

This copies one of the sheets to another worksheet and I know it imports into the web app without issue, however I would like a separate file with two combined worksheets.

Sub KopyKat()
With Worksheets("ITDepExport")
Worksheets("TEST").Range(.UsedRange.Address).Cells.Value2 = .UsedRange.Value2
End With
End Sub

Link to example workbook with the worksheets above

CodePudding user response：

Export-Append Worksheets

This will export the worksheets from the list to a new one-worksheet workbook.
It is assumed that all of the worksheets have the same headers.
Only the first worksheet will be copied with the headers, while only the data from the remaining worksheets will be appended in the destination worksheet.
The worksheets contain formulas that produce blank rows at the bottom which are excluded by finding the last non-blank cell (row) by using the Find method with its LookIn argument set to the parameter xlValues.
Another requirement was to copy only values (no formulas or formats) which is achieved by copying by assignment: drg.Value = srg.Value.

Option Explicit

Sub ExportAppendWorksheets()
    Const ProcName As String = "ExportAppendWorksheets"
    
    Dim WasSaved As Boolean
    Dim dwb As Workbook
    
    On Error GoTo ClearError

    Const wsNamesList As String = "ITDepExport,ITRepExport" ' add more
    
    Dim dwsNames() As String: dwsNames = Split(wsNamesList, ",")
    
    Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet
    Dim srg As Range
    Dim slrCell As Range
    Dim dws As Worksheet
    Dim drg As Range
    Dim dfCell As Range
    Dim n As Long
    
    For n = 0 To UBound(dwsNames)
        
        Set sws = swb.Worksheets(dwsNames(n))
        With sws.UsedRange ' 'xlValues' is crucial since there are formulas
            Set slrCell = .Find("*", .Cells(.Rows.Count, .Columns.Count), _
                xlValues, , xlByRows, xlPrevious)
            If n = 0 Then ' include headers
                Set srg = .Resize(slrCell.Row - .Row   1)
            Else ' exclude headers
                Set srg = .Resize(slrCell.Row - .Row).Offset(1)
            End If
        End With
        
        If n = 0 Then
            Set dwb = Workbooks.Add(xlWBATWorksheet) ' one worksheet
            Set dws = dwb.Worksheets(1)
            Set dfCell = dws.Range("A1")
        End If
        
        dws.Name = sws.Name
        Set drg = dfCell.Resize(srg.Rows.Count, srg.Columns.Count)
        drg.Value = srg.Value
        Set dfCell = dfCell.Offset(srg.Rows.Count)
        Set sws = Nothing
             
    Next n
    
    Dim dFilePath As Variant
    dFilePath = Application.GetSaveAsFilename(InitialFileName:="", _
        FileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="Save As")
    
    If dFilePath <> False Then
        Application.DisplayAlerts = False ' overwrite without confirmation
        dwb.SaveAs dFilePath
        Application.DisplayAlerts = True
        WasSaved = True
    Else
        Debug.Print "'" & ProcName & "': Saving canceled."
    End If
    
ProcExit:
    
    If Not dwb Is Nothing Then
        dwb.Close SaveChanges:=False
    End If
    
    If WasSaved Then
        MsgBox "Worksheets export-appended.", vbInformation, ProcName
    Else
        MsgBox "Either you canceled the save or an error occurred. " _
            & "Look for a message in the Immediate window (VBE Ctrl G).", _
            vbCritical, ProcName
    End If
    
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Sub