Combine Two VBA Codes

[ramkrau]

I have a workbook with many tabs that currently will create a folder and save each tab as a separate CSV file into that folder.
Ultimately, what I'd like so for those files to then combine into one big CSV file.
The headers of each tab are identical, so I only need the header row once.

My macro for the exporting as CSV files is:

Sub SplitWorkbook()
CarryOn = MsgBox("Do you want to export CSV files? NOTE: This may take up to 60 seconds.", vbYesNo, "Export CSV Test Files")
If CarryOn = vbYes Then
ActiveWorkbook.Save
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim FolderName As String
Application.ScreenUpdating = False
Set xWb = Application.ThisWorkbook
DateString = Format(Now, "mm-dd-yyyy hh-mm-ss")
FolderName = xWb.Path & "" & "EU Test Cases " & DateString
MkDir FolderName
For Each xWs In xWb.Worksheets
If (xWs.Name <> "Taxonomy") And (xWs.Name <> "Master") And (xWs.Name <> "Directions") And (xWs.Name <> "EU Shipping & Gift Wrap") And (xWs.Name <> "Tax Rates") And (xWs.Name <> "RuleFile") And (xWs.Name <> "TDM") Then
xWs.Copy
If Val(Application.Version) < 12 Then
FileExtStr = ".csv": FileFormatNum = 6
Else
Select Case xWb.FileFormat
Case 51:
FileExtStr = ".csv": FileFormatNum = 6
Case 52:
If Application.ActiveWorkbook.HasVBProject Then
FileExtStr = ".csv": FileFormatNum = 6
Else
FileExtStr = ".csv": FileFormatNum = 6
End If
Case 56:
FileExtStr = ".csv": FileFormatNum = 6
Case Else:
FileExtStr = ".csv": FileFormatNum = 6
End Select
End If
xFile = FolderName & "" & Application.ActiveWorkbook.Sheets(1).Name & FileExtStr
Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum
Application.ActiveWorkbook.Close False
End If
Next xWs
MsgBox "You can find the files in " & FolderName
Application.ScreenUpdating = True
End If
End Sub

I've googled and found some ways to have files in a folder combine, but I can't figure out how to combine that so that it reads the files in the folder that the above macro created, and I can't figure out how to get the header row (1:1) to print only once. (There is not a fixed number of cells, so I just need it to print whatever has content below 1:1... one week it could be 1000 rows, the next 900 rows, then 1200 rows, etc.)

Anyone able to help me out? Pretty please?

 

[MoshiM]

One way of doing this would be to
Store your file paths in an array
Open those files and store the usedrange from the specified sheet inside a collection and then recombine the stored arrays at the end and then write that array to a new workbook.

Ex:

Sub Compile_Sheets()

Dim Data As Variant, Array_Collection As New Collection, Workbook_Names As String, _
WS As Worksheet, x As Long, y As Long, z As Long, Temp_A As Variant, W As Long

[COLOR=#0000ff]'Note that workbook_names must be fully defined with their path as well[/COLOR]

Workbook_Names = Split(WB1, WB2, WB3, ",")
[COLOR=#0000ff]'WB1,WB2, etc is a place holder for file names [Commas are mandatory][/COLOR]

For x = LBound(Workbook_Names) To UBound(Workbook_Names)

   Set WB = Workbooks.Open(Workbook_Names(x)).Sheets(1) 'First Sheet of specified worksheet

   With WB.UsedRange
       
       .Parent.ActiveWindow.Visible = False
       
       If x = LBound(Workbook_Names) Then [COLOR=#0000ff]'if first file then store headers in Collection[/COLOR]

             Array_Collection.Add .Value
               
       Else
             Array_Collection.Add .Offset(1, 0).Resize(.Rows.count - 1, .Columns.count).Value
         
             y = y - 1

       End If
       
       z = WorksheetFunction.Max(z, .Columns.count)
       y = y + .Rows.count
       .Parent.Close False 'close file 
   End With
   
  
       
Next x

ReDim Data(1 To y, 1 To z)

W = 1

For z = 1 To Array_Collection.count 'loop arrays within Collection

    Temp_A = Array_Collection(z)
    
    For x = 1 To UBound(Temp_A, 1) 'loop rows
        For y = 1 To UBound(Temp_A, 2) 'loop columns
            Data(W, y) = Temp_A(x, y)
        Next y
        W = W + 1
    Next x
    
Next z

With Workbooks.Add
    
    .Worksheets(1).Range("A1").Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data 'Write data to sheet

    [COLOR=#0000ff]'[SaveAs] stuff goes here[/COLOR]
    
    .close
    
End With

End Sub

 

[ZVI]

Hi,
You may try this:

Sub SheetsToCsv()
 
  Const ExcludeSheets = "/Taxonomy/Master/Directions/EU Shipping & Gift Wrap/Tax Rates/RuleFile/TDM/"
  
  Dim sDate As String, sFolderName As String, sFileCsv As String
  Dim Sh As Worksheet, Wb As Workbook
  Dim i As Long, j As Long, k As Long, n As Long, m As Long
  
  If MsgBox("Do you want to export CSV files?" _
          & "NOTE: This may take up to 60 seconds.", _
            vbYesNo, "Export CSV Test Files") = vbNo Then Exit Sub
  
  Set Wb = ThisWorkbook
  If Not Wb.Saved Then Wb.Save
  
  sDate = Format(Now, "mm-dd-yyyy hh-mm-ss")
  sFolderName = Wb.Path & "\" & "EU Test Cases " & sDate
  sFileCsv = sFolderName & "\" & Wb.Sheets(1).Name & ".csv"
  
  ' Create destination folder
  If Dir(sFolderName, vbDirectory) = vbNullString Then MkDir sFolderName
  
  ' Disable blinking
  Application.ScreenUpdating = False
  
  ' Trap errors
  On Error GoTo exit_
  
  ' Collect data for export
  With Workbooks.Add(xlWBATWorksheet)
    n = Wb.Worksheets.Count
    j = 1
    For Each Sh In Wb.Worksheets
      m = m + 1
      Application.StatusBar = "Sheets processing: " & m & "/" & n
      If InStr(1, "/" & Sh.Name & "/", ExcludeSheets, vbTextCompare) = 0 Then
        ' Data rows count
        i = Sh.UsedRange.Find(What:="*", LookIn:=xlFormulas, _
                              SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
                              SearchFormat:=False).Row
        If j > 1 Then i = i - 1
        ' Columns count
        If k = 0 Then k = Sh.Cells(1).CurrentRegion.Columns.Count
        ' Copy value from Sh to the destination common sheet
        .Sheets(1).Range("A" & j).Resize(i, k).Value = Sh.Range("A" & IIf(j = 1, 1, 2)).Resize(i, k).Value
        ' Next dest empty row
        j = j + i
      End If
    Next
    
    ' Export the collected data to CSV
    .SaveAs sFileCsv, FileFormat:=xlCSV
    
    ' Close the temporary created workbook
    .Close SaveChanges:=False
    
  End With

exit_:
  
  ' Restore screen updating
  Application.ScreenUpdating = True
  Application.StatusBar = False
  
  ' Inform about error or the dest folder
  If Err Then
    MsgBox Err.Description, vbExclamation, "Error"
  Else
    MsgBox "You can find the files in " & sFolderName
  End If
  
End Sub

Regards