VBA Help splitting data based on a ID #

[cmcbeath]

I need some help finishing some code. I have large tables that i need to split into individual files based on an identification number in a column. I will attach a sample document. I have already written everything after "selecting" all the rows with a certain ID number, meaning the transfer into a new file, etc. But I cant figure out an efficient way to select all the rows with the same ID # so i can copy them into its own file.

Thank you for the help.

[p45cal]

I need some help finishing some code.There's no code in your attachment to finish!

[Paul_Hossler]

Something like this should get you started




Option Explicit


Sub SplitID()
Dim i As Long
Dim r As Range
Dim C As Collection
Dim ws As Worksheet
Dim wb As Workbook
Dim ID As String, W As String

Application.ScreenUpdating = False

Set r = ActiveSheet.Cells(1, 1).CurrentRegion

Set C = New Collection

'make unique list
On Error Resume Next
For i = 2 To r.Rows.Count
C.Add r.Cells(i, 1).Value, CStr(r.Cells(i, 1).Value)
Next i
On Error GoTo 0


For i = 1 To C.Count

'get the ID
ID = C.Item(i)

'delete ws with that ID just in case
On Error Resume Next
Application.DisplayAlerts = False
Worksheets(ID).Delete
Application.DisplayAlerts = True
On Error GoTo 0

'add ws named ID
Worksheets.Add
Set ws = ActiveSheet
ws.Name = ID

'filter data on ID
r.AutoFilter Field:=1, Criteria1:=ID

'copy to ID ws
r.SpecialCells(xlCellTypeVisible).Copy ws.Range("A1")


'get wb name
W = ThisWorkbook.Path & Application.PathSeparator & ID & ".xlsx"

'delete wb with that ID just in case
On Error Resume Next
Application.DisplayAlerts = False
Kill W
Application.DisplayAlerts = True
On Error GoTo 0

'copy ws to new wb
ws.Move
Set wb = ActiveWorkbook
wb.SaveAs W, xlWorkbookDefault
wb.Close False

ThisWorkbook.Activate
Next i


ActiveSheet.AutoFilterMode = False


Application.ScreenUpdating = False



MsgBox "Done"


End Sub

[snb]

This is all you need, using the builtin options in Excel (advancedfilter)


Sub M_snb()
If Sheets.Count = 1 Then Sheets.Add , Sheets(Sheets.Count)

With Sheet1
.Columns(1).AdvancedFilter 2, , .Cells(1, 6), True
sn = .Cells(1, 6).CurrentRegion
.Cells(1, 6).Offset(2).Resize(UBound(sn)).ClearContents

For j = 2 To UBound(sn)
.Cells(2, 6) = sn(j, 1)
Sheet2.UsedRange.ClearContents
.Cells(1).CurrentRegion.AdvancedFilter 2, .Cells(1, 6).CurrentRegion, Sheet2.Cells(1)
Sheet2.Copy
With ActiveWorkbook
.SaveAs "G:\OF\" & sn(j, 1), 51
.Close -1
End With
Next

.Cells(1, 6).CurrentRegion.ClearContents
End With
End Sub