I have the following code that will filter the data and then create a new file for every unique filtered record. The code works correctly in that it is fllitering and creating the new files. The issue is that it is not pasting the header as well. Also, if there is multiple records for a filter, it is only pasting to the first line of the new file and continuously overwriting the data. Theses are the only two issues that I am noticing with this file. I am wondering if there is code that I could add after wb.Sheets(1).Paste that would solve the issues with this code. Thanks
Sub SplitWorkbook(Optional colLetter As String, Optional SavePath As String)
If colLetter = "" Then colLetter = "D"
Dim lastValue As String
Dim hasHeader As Boolean
Dim wb As Workbook
Dim c As Range
Dim currentRow As Long
hasHeader = True 'Indicate true or false depending on if sheet has header row.
If SavePath = "" Then SavePath = ThisWorkbook.Path
'Sort the workbook.
ThisWorkbook.Worksheets(1).Sort.SortFields.Add Key:=Range(colLetter & ":" & colLetter), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ThisWorkbook.Worksheets(1).Sort
.SetRange Cells
If hasHeader Then ' Was a header indicated?
.Header = xlYes
Else
.Header = xlNo
End If
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For Each c In ThisWorkbook.Sheets(1).Range("D:D")
If c.Value = "" Then Exit For
If c.Row = 1 And hasHeader Then
Else
If lastValue <> c.Value Then
If Not (wb Is Nothing) Then
wb.SaveAs SavePath & "\" & lastValue & ".xls"
wb.Close
End If
lastValue = c.Value
currentRow = 1
Set wb = Application.Workbooks.Add
End If
ThisWorkbook.Sheets(1).Rows(c.Row & ":" & c.Row).Copy
wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Select
wb.Sheets(1).Paste
End If
Next
If Not (wb Is Nothing) Then
wb.SaveAs SavePath & "\" & lastValue & ".xls"
wb.Close
End If
End Sub
Bookmarks