I have working code, but trying to make some changes.
1. I want to add the current date to the file name when it splits out.
2. This VBA asks for which column I want to use, but it will only let me put in a number. I want to use the column letters instead.
3. My workbook has multiple sheets and if I run this code, it runs against entire workbook. I would like it to run on active sheet only.
1. I want to add the current date to the file name when it splits out.
2. This VBA asks for which column I want to use, but it will only let me put in a number. I want to use the column letters instead.
3. My workbook has multiple sheets and if I run this code, it runs against entire workbook. I would like it to run on active sheet only.
Code:
Option Explicit
Sub ExportToWorkbooks()
Const aibPrompt As String = "Which column would you like to filter by?"
Const aibtitle As String = "Filter Column"
Const aibDefault As Long = 3
Dim dFileExtension As String: dFileExtension = ".xlsx"
Dim dFileFormat As XlFileFormat: dFileFormat = xlOpenXMLWorkbook
Dim dFolderPath As String: dFolderPath = "C:\Users\WalteR01\Desktop\VPN Revalidations\Split by Manager\"
If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
If Len(Dir(dFolderPath, vbDirectory)) = 0 Then Exit Sub ' folder not found
If Left(dFileExtension, 1) <> "." Then dFileExtension = "." & dFileExtension
Application.ScreenUpdating = False
Dim sCol As Variant
sCol = Application.InputBox(aibPrompt, aibtitle, aibDefault, , , , , 1)
If Len(CStr(sCol)) = 0 Then Exit Sub ' no entry
If sCol = False Then Exit Sub ' canceled
Dim sws As Worksheet: Set sws = ActiveSheet
If sws.FilterMode Then sws.ShowAllData
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim srCount As Long: srCount = srg.Rows.Count
If srCount < 3 Then Exit Sub ' not enough rows
Dim srrg As Range: Set srrg = srg.Rows(1) ' to copy column widths
Dim scrg As Range: Set scrg = srg.Columns(sCol)
Dim scData As Variant: scData = scrg.Value
' Write the unique values from the 1st column to a dictionary.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare ' case insensitive
Dim Key As Variant
Dim r As Long
For r = 2 To srCount
Key = scData(r, 1)
If Not IsError(Key) Then ' exclude error values
If Len(Key) > 0 Then ' exclude blanks
dict(Key) = Empty
End If
End If
Next r
If dict.Count = 0 Then Exit Sub ' only error values and blanks
Erase scData
Dim dwb As Workbook
Dim dws As Worksheet
Dim dfcell As Range
Dim dFilePath As String
For Each Key In dict.Keys
' Add a new (destination) workbook and reference the first cell.
Set dwb = Workbooks.Add(xlWBATWorksheet) ' one worksheet
Set dws = dwb.Worksheets(1)
Set dfcell = dws.Range("A1")
' Copy/Paste
srrg.Copy
dfcell.PasteSpecial xlPasteColumnWidths
srg.AutoFilter sCol, Key
srg.SpecialCells(xlCellTypeVisible).Copy dfcell
sws.ShowAllData
dfcell.Select
' Save/Close
dFilePath = dFolderPath & Key & dFileExtension ' build the file path
Application.DisplayAlerts = False ' overwrite without confirmation
dwb.SaveAs dFilePath, xlOpenXMLWorkbook
Application.DisplayAlerts = True
dwb.Close SaveChanges:=False
Next Key
sws.AutoFilterMode = False
Application.ScreenUpdating = True
MsgBox "Data exported.", vbInformation
End Sub