Vbapadawan
New Member
- Joined
- Jul 5, 2015
- Messages
- 13
I'm happy with the way the code works (thanks Skywriter), I have worked out how to append the filtered data to an existing sheet if it already exists, but I just cant seem to do it without the heading row.
I have followed the code in the multiple posts on the subject but keep getting a runtime 1004 error. stopping on the code below
What am I doing wrong???
View attachment 68223
Here is the entire code
I have followed the code in the multiple posts on the subject but keep getting a runtime 1004 error. stopping on the code below
What am I doing wrong???
Code:
Rng2.Offset(1, 0).Resize(Rng2.Rows.Count - 1) _
.SpecialCells(xlCellTypeVisible).Copy Sheets(c.Value).Range("A" & MaxRows + 1)
View attachment 68223
Here is the entire code
Code:
Option Explicit
Sub Split_worksheet()
Dim c As Range
Dim rng As Range
Dim Rng2 As Range
Dim LR As Long
Dim MaxRows As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
' Turn off alerts so the sheets will be deleted without having to acknowledge them.
Application.DisplayAlerts = False
For Each ws In Worksheets
If Not ws.Name Like "Report Sheet*" And Not ws.Name = "COUNT" Then
ws.Delete
End If
Next ws
Application.DisplayAlerts = True
' Loop through remaining sheets which all begin with "Report Sheet", new sheets added are not looped.
For Each ws In Worksheets
If Not ws.Name = "COUNT" Then
MsgBox ws.Name
With ws
If .AutoFilterMode = True Then .AutoFilterMode = False
LR = .Cells(Rows.Count, "A").End(xlDown).Row
' RR = .Cells(Rows.Count, "A").End(xlDown).Row
Set rng = .Range("A1:AF" & LR)
' Create a unique list of manager names in column AM.
.Columns("AM").ClearContents ' Clear any existing data.
.Range("AF1:AF" & LR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("AM1"), Unique:=True
' Loop through the unique list of manager names. Autofilter the data based on those names.
' Create a new sheet based on the manager name. If a sheet with the manager's name already exists
' then do not create a a new sheet just go to the next manager and try again.
For Each c In .Range("AM2", .Cells(Rows.Count, "AM").End(xlUp)) '
With rng
.AutoFilter
.AutoFilter Field:=32, Criteria1:=c.Value
' Check if a sheet with the manager's name already exists. It it does do not add a sheet just
' skip to the next manager's name and try again.
If Not Evaluate("ISREF('" & c.Value & "'!A1)") Then ' Check if the worksheet already exists.
Sheets.Add(After:=Sheets(Worksheets.Count)).Name = c.Value
Else
GoTo 10
End If
.SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Range("A1")
Sheets(c.Value).Columns.AutoFit
End With
1
Next c
End With
End If
Next ws
Application.ScreenUpdating = True
GoTo 100
10
'If the sheet already exists, the data is added to existing sheet
'find next blank cell in target sheet
MaxRows = Sheets(c.Value).Cells(Rows.Count, "A").End(xlUp).Row
' Set rng to the visible cells in My_Range without the header row
'copy rows without headings
'ws.AutoFilter.Range.Copy Sheets(c.Value).Range("A" & MaxRows + 1) ' works but includes headings
Set Rng2 = ws.AutoFilter.Range
Rng2.Offset(1, 0).Resize(Rng2.Rows.Count - 1) _
.SpecialCells(xlCellTypeVisible).Copy Sheets(c.Value).Range("A" & MaxRows + 1)
Sheets(c.Value).Columns.AutoFit
GoTo 1
On Error Resume Next
100
End Sub