A short code that works with your sample file (delete all your Tablen sheets first):
Code:
Sub blah()
For Each are In Range("A1").SpecialCells(xlCellTypeConstants, 23).Areas
With Sheets.Add(after:=Sheets(Sheets.Count))
are.Copy .Range("B2")
.Name = are.Cells(1, 1).Value
End With
Next are
End Sub
but this requires that there are no formulae in the tables at all.
A more inclusive technique looks for formulae and constant values in the cells (and won't crash if the sheet is empty):
Code:
Sub blah2()
Dim FormulaAreas As Range, myAreas As Range
On Error Resume Next
Set myAreas = Range("A1").SpecialCells(xlCellTypeConstants, 23)
Set FormulaAreas = Range("A1").SpecialCells(xlCellTypeFormulas, 23)
On Error GoTo 0
If myAreas Is Nothing Then
If Not FormulaAreas Is Nothing Then Set myAreas = FormulaAreas
Else
If Not FormulaAreas Is Nothing Then Set myAreas = Union(myAreas, FormulaAreas)
End If
If Not myAreas Is Nothing Then
For Each are In myAreas.Areas
With Sheets.Add(after:=Sheets(Sheets.Count))
are.Copy .Range("B2")
.Name = are.Cells(1, 1).Value
End With
Next are
End If
End Sub
Both codes work on the active sheet so make sure that the Sample sheet is the active one when running.
Neither of them check that the top left cell of each table contains a valid sheet name.
Both codes rely on the fact that the original tables are surrounded by blank cells or the edge of the sheet (like the CurrentRegion you suggest).
I haven't addressed the PowerPoint bit yet; would it be OK if you could get the separate tables into PowerPoint without adding new sheets?
Do you want to link the tables in PowerPoint to the excel ranges (tables) or import the data into PowerPoint without a link, embed a spreadsheet object? Perhaps a picture?
Your question wasn't too specific about those points.
Bookmarks