Sub CREATESHEET()
Dim MainSheet As Worksheet
Dim TempSheet As Worksheet
Dim TargetSheet As Worksheet
Dim MyRange As Range
Dim ColHeading As Range
Dim ListRange As Range
Dim TempRange As Range
Dim TempCell As Range
Set MainSheet = Worksheets("ALL")
'MsgBox MainSheet.Range("A1").Value
Set TempSheet = Worksheets.Add
With MainSheet
Set MyRange = .UsedRange
Set ColHeading = .Range("A1", .Cells.SpecialCells(xlCellTypeLastCell))
Intersect(ColHeading, .Columns("C")).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=TempSheet.Range("A1"), _
Unique:=True
TempSheet.Range("D1").Value = TempSheet.Range("A1").Value
End With
With TempSheet
Set ListRange = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
End With
For Each TempCell In ListRange.Cells
MsgBox TempCell.Value
If SHEETEXIST(TempCell.Value) = False Then
Set TargetSheet = Sheets.Add
On Error Resume Next
TargetSheet.Name = TempCell.Value
TargetSheet.Move after:=Sheets(Sheets.Count)
Else
Set TargetSheet = Worksheets(TempCell.Value)
TargetSheet.Cells.Clear
TargetSheet.Cells.ClearComments
End If
TempSheet.Range("D2").Value = "=" & Chr(34) & "=" & TempCell.Value & Chr(34)
'MainSheet.Rows("1:1").Copy Destination:=TargetSheet.Range("A1")
ColHeading.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=TempSheet.Range("D1:D2"), _
CopyToRange:=TargetSheet.Range("A1"), _
Unique:=False
Next TempCell
Application.DisplayAlerts = False
TempSheet.Delete
'MainSheet.Save
End Sub
Function SHEETEXIST(WksName As String) As Boolean
On Error Resume Next
SHEETEXIST = CBool(Len(Worksheets(WksName).Name) > 0)
End Function
Bookmarks