Option Explicit
Sub Macro1()
Dim wsSrc As Worksheet
Dim strSavePath As String, strLastCol As String, strSrcCol As String
Dim clnMyItems As New Collection
Dim lngMyRow As Long, lngLastRow As Long, lngLastCol As Long, i As Long
Dim varItem As Variant
Dim rngFiltered As Range
Dim wb As Workbook
Dim blnDoesFileExist As Boolean, blnWasFileOpen As Boolean
Application.ScreenUpdating = False
strSrcCol = "D" 'Column to base the creation of the new workbook(s) on. Change to suit if necessary.
Set wsSrc = ThisWorkbook.Sheets("Sheet1") 'Sheet name containing the divisions in column 'srcCol'. Change to suit if necessary.
On Error Resume Next
wsSrc.ShowAllData
On Error GoTo 0
strSavePath = "C:\keysaf\" 'Path to save individual division workbooks. This WILL need to be changed to meet your specific needs.
strSavePath = IIf(Right(strSavePath, 1) <> "\", strSavePath & "\", strSavePath)
lngLastRow = wsSrc.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lngLastCol = wsSrc.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
strLastCol = Split(wsSrc.Cells(lngLastRow, lngLastCol).Address, "$")(1)
'Create an unique list of items
For lngMyRow = 2 To lngLastRow
On Error Resume Next
clnMyItems.Add CStr(wsSrc.Range(strSrcCol & lngMyRow)), wsSrc.Range(strSrcCol & lngMyRow)
On Error GoTo 0
Next lngMyRow
'Create and save a new workbook for each item if the workbook does not exist (the new workbook will only have the sheet with the data) or else append the data to the first sheet
For Each varItem In clnMyItems
wsSrc.Range("$A$1:$" & strLastCol & "$" & lngLastRow).AutoFilter Field:=Range(strSrcCol & ":" & strSrcCol).Column, Criteria1:=CStr(varItem), Operator:=xlFilterValues
blnDoesFileExist = Len(Dir(strSavePath & CStr(varItem) & ".xlsx"))
If blnDoesFileExist = False Then
Set rngFiltered = wsSrc.Range("$A$1:$" & strLastCol & "$" & lngLastRow).SpecialCells(xlCellTypeVisible)
If Not rngFiltered Is Nothing Then
i = i + 1
Set wb = Workbooks.Add(1)
rngFiltered.Copy
With wb.Sheets(1).Range("A1")
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteValues
.Select
End With
Application.DisplayAlerts = False 'Save over a workbook with the same name, no questions asked
wb.SaveAs strSavePath & CStr(varItem) & ".xlsx", 51 '51 = xlOpenXMLWorkbook (without macro's in 2007-2016, xlsx). Change to suit if necessary.
wb.Close SaveChanges:=False
Application.DisplayAlerts = True
End If
Else
On Error Resume Next
Set wb = Workbooks(CStr(varItem) & ".xlsx")
If wb Is Nothing Then
Set wb = Workbooks.Open(strSavePath & CStr(varItem) & ".xlsx")
blnWasFileOpen = False
Else
blnWasFileOpen = True
End If
On Error GoTo 0
Set rngFiltered = wsSrc.Range("$A$2:$" & strLastCol & "$" & lngLastRow).SpecialCells(xlCellTypeVisible)
If Not rngFiltered Is Nothing Then
i = i + 1
rngFiltered.Copy wb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0) 'Pastes the data into the first available row in Col. A into the first sheet (furthest left) of 'wb' workbook.
If blnWasFileOpen = False Then
wb.Close True
End If
End If
End If
On Error Resume Next
wsSrc.ShowAllData
On Error GoTo 0
Next varItem
Application.ScreenUpdating = False
If i = 0 Then
MsgBox "There were no unique entries in Col. " & strSrcCol & " of """ & wsSrc.Name & """ to create any workbooks.", vbExclamation
Else
MsgBox Format(i, "#,##0") & " workbooks have now been updated in """ & strSavePath & """", vbInformation
End If
End Sub
