Split data into new workbooks based on data in a specific column, but exclude that specific column from the output files

Question

I am very new to VBA and I currently have built a code by putting together and amending different codes I've found online and adding a bit of my own code. I have the existing working code below but need help making further tweaks.

Right now after filtering out any #N'A's in column I and renaming some headers, the code will create a new worksheet for each new item listed in column D. Instead I need it to create a new workbook for every item listed in column I, but the data that is copied over to each new workbook should only be from columns A to H and should still include the same entire heading from rows 1 to 15.

A huge bonus would be if we can also get the new workbooks to then Save AS under the same name as the data in column I.

Attached is an image of what the file would look like, so that you can get a visual idea.

the existing code is below:

Sub SplitData()
Set asheet = ActiveSheet
    asheet.Range("A15:I1048574").AutoFilter Field:=9, Criteria1:="#N/A"
    asheet.Range("A16:I1048574").SpecialCells _
    (xlCellTypeVisible).EntireRow.Delete
    asheet.ShowAllData
  Range("B1").Value = "MAIN HEADER"
    Range("D15").Value = "SUBHEADING1"
    Range("E15").Value = "SUBHEADING2"
    Range("F15").Value = "SUBHEADING3"
    Range("G15").Value = "SUBHEADING4"
    Range("H15").Value = "SUBHEADING5"
    
lastrow = asheet.Range("D" & Rows.Count).End(xlUp).Row
myarray = uniqueValues(asheet.Range("D16:D" & lastrow))
For i = LBound(myarray) To UBound(myarray)
 Sheets.Add.Name = myarray(i)
 asheet.Range("A15:H" & lastrow).AutoFilter Field:=4, Criteria1:=myarray(i)
asheet.Range("A1:H" & lastrow).SpecialCells(xlCellTypeVisible).Copy _
        Sheets(myarray(i)).Range("A1")
 asheet.Range("A15:H" & lastrow).AutoFilter
Next i
End Sub

Private Function uniqueValues(InputRange As Range)
    Dim cell As Range
    Dim tempList As Variant: tempList = ""
    For Each cell In InputRange
        If cell.Value <> "" Then
            If InStr(1, tempList, cell.Value) = 0 Then
                If tempList = "" Then tempList = Trim(CStr(cell.Value)) Else tempList = tempList & "|" & Trim(CStr(cell.Value))
            End If
        End If
    Next cell
    uniqueValues = Split(tempList, "|")
End Function

I tried to change instances in the code where it specified column D to column I but I would get the error code mismatch.

I don't completely understand the Private function part of the code, as that it entirely copied from someone else's example so I am having trouble figuring out how to rewrite it.

Any help is appreciated.

Answer 1

Application oriented learning can definitely be frustrating as you work your way into new realms...been there before, but once you get your solution working, it's extremely rewarding.

You are definitely moving in the right direction. Going off your example photo, when you switched from column D to column I, the different forms of "#N/A" most likely threw off the uniqueValues function. In column D, the "#N/A" values are text strings (no green error triangle), but in column I, they are errors. VBA will handle them differently because the error value isn't the same as the displayed text in Excel.

I've taken what you have started and organized it to follow the logical flow that you described. When I started out, this helped me better picture what is going on. Even if it isn't the most efficient process or minimal code, hopefully it helps you understand the process.

In regards to the uniqueValues function, the function is taking your range that is passed as an input and looking for all the unique values. As it loops through the values, it searches a temp text string for the value. If it finds it, it moves to the next value; if not, it adds the value to the text string in a pattern. At the end, it splits the string on that pattern and returns an array of values. In the code below, this is handled by the collection object. The benefit here is that the object, by nature, can only hold one record for each unique key so there is no need to compare. All you have to do is add the value and handle the errors, which also handles the #N/A items.

Sub SplitDataToNewWorkbook()

'// Dimension your variables
  Dim wb, newWB As Workbook
  Dim ws, newWS As Worksheet
  Dim DataRange, FullRange, HeaderRange As Range
  Dim wbArr As New Collection '// collections store items with unique keys

'// Declare your starting values
  Set wb = ThisWorkbook
  Set ws = wb.Worksheets("Sheet1")

  '// Get your last row
  LastRow = ws.Range("I" & Rows.Count).End(xlUp).Row

  '// Defines the ranges we want to copy and work with
  Set HeaderRange = ws.Range("1:14") '// above data
  Set DataRange = ws.Range("A15:H" & LastRow) '// data table to copy
  Set FullRange = ws.Range("A15:I" & LastRow) '// data table with all data

'// Get the Unique Values in vLookup Column
'// Tries to add the name to the collection if it is new else moves on...skips #N/A
  On Error Resume Next
  For Each wbName In ws.Range("I16:I" & LastRow)
    wbArr.Add wbName.Value2, wbName.Value2
  Next
  On Error GoTo 0

'// Enables AutoFilter to the full data range, resumes if already on
  On Error Resume Next
  FullRange.AutoFilter

'// Loop through each wb Name to create new workbooks
  For Each wbName In wbArr
    
    '// Sets new workbook and worksheet
    Set newWB = Workbooks.Add
    Set newWS = newWB.Worksheets("Sheet1")
    
    '// Applies the filter for the wbName on column I
    FullRange.AutoFilter Field:=9, Criteria1:=wbName
    
    '// Copies and applies the header section to the new file
    HeaderRange.Copy
    newWS.Range("1:14").PasteSpecial
    Application.CutCopyMode = False '// Clears clipboard
    
    '// Copies and applies visible data to the new file
    DataRange.SpecialCells(xlCellTypeVisible).Copy
    newWS.Range("A15").PasteSpecial
    Application.CutCopyMode = False '// Clear clipboard
    
    '// Updates data headers and other cells as needed
    newWS.Range("D15").Value2 = "Subheading 1"
    '// Repeat to update other headers
    
    '// Saves the workbook to the same folder as the current workbook with value from column I
    '// Replace "wb.Path" as needed to save the file to your desired location
    newWB.SaveAs wb.Path & "\" & wbName & ".xlsx"
    
    '// Closes the file (remove if you want it to stay open)
    newWB.Close
    
    '// Resets the newWB variables and shows all source data
    Set newWB = Nothing
    On Error Resume Next
    ws.ShowAllData
    
  Next

End Sub