How to modify this code to work in Excel table as well

I had this question after viewing VBA modification help needed from earlier solution (VBA to modification to take it from table instead of sheet).


I have found this code below in EE.   it works fine when the data is normal sheet.

but if i have the data in form of Excel table like the one attached.  it does not work properly.

how can this code be modified that when if it is normal data it works and also when it is table it should work too.

thanks.

'**********************************************************************************************************
'**      This code Split the workbook into multiple sheets and if needed multiple workbooks
'**      Run the Sub Routine Split_Column_Data()
'**      Author : ProfessorJimJam   01/09/2015
'**      Version : 1.0
'**      acknowledgements: used the lastrow and lastcol functions from blog of Ron de Bruin Microsoft Office MVP - Excel & GetDirectory Function from Microsoft Answers
'**
#If VBA7 Then
    Private Type BROWSEINFO
        hOwner As LongPtr
        pidlRoot As LongPtr
        pszDisplayName As String
        lpszTitle As String
        ulFlags As Long
        lpfn As LongPtr
        lParam As LongPtr
        iImage As Long
    End Type
                        
    Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
        (lpBrowseInfo As BROWSEINFO) As LongPtr
        
        Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As LongPtr, ByVal pszPath As String) As LongPtr
        
         Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As LongPtr, x As LongPtr, pos As Integer
#Else
    Private Type BROWSEINFO
        hOwner As Long
        pidlRoot As Long
        pszDisplayName As String
        lpszTitle As String
        ulFlags As Long
        lpfn As Long
        lParam As Long
        iImage As Long
    End Type
                        
    Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
        (lpBrowseInfo As BROWSEINFO) As Long
        
        Declare Function SHGetPathFromIDList Lib "shell32.dll" _
  Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _
  As Long

        
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer
#End If
Private Const BIF_RETURNONLYFSDIRS = &H1


Function GetDirectory(Optional Msg) As String


'   Root folder = Desktop
    bInfo.pidlRoot = 0&

'   Title in the dialog
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
    Else
        bInfo.lpszTitle = Msg
    End If
    
'   Type of directory to return
    bInfo.ulFlags = &H1

'   Display the dialog
    x = SHBrowseForFolder(bInfo)
    
'   Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
       GetDirectory = ""
    End If
End Function

Sub Split_Column_Data()
Dim LR As Long, LC As Integer, i As Long, iStart As Long, iEnd As Long
Dim Ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
Dim sh As Worksheet, Master As String, Folder As String, Fname As String
On Error Resume Next
Set r = Application.InputBox("Click in the column to extract by", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
t = Now
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ActiveSheet
    Master = .Name
   LR = LastRow(ActiveSheet)
   LC = LastCol(ActiveSheet)
    .Range(.Cells(2, 1), Cells(LR, LC)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To LR
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            Sheets.Add After:=Sheets(Sheets.Count)
            Set Ws = ActiveSheet
           On Error Resume Next
            Ws.Name = .Cells(iStart, iCol).Value
            On Error GoTo 0
            Ws.Range(Cells(1, 1), Cells(1, LC)).Value = .Range(.Cells(1, 1), .Cells(1, LC)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LC)).Copy Destination:=Ws.Range("A2")
            iStart = iEnd + 1
        End If
    Next i
End With
Dim Src As Range

    For Each Ws In ActiveWorkbook.Worksheets
        With Ws
            Set Src = Ws.Range("A1").CurrentRegion
            If Src.ListObject Is Nothing Then
                .ListObjects.Add SourceType:=xlSrcRange, Source:=Src, xlListObjectHasHeaders:=xlYes
            End If
        End With
    Next Ws
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Completed in " & Format(Now - t, "hh:mm:ss.00"), vbInformation
If MsgBox("Do you want to save the separated sheets as workbooks", vbYesNo + vbQuestion) = vbYes Then
    Folder = "Select the folder to save the workbooks"
    Folder = GetDirectory(Folder)
    If Folder = "" Then Exit Sub
    Prefix = InputBox("Enter a prefix (or leave blank)")
    Application.ScreenUpdating = False
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> Master Then
            sh.Copy
            Fname = Folder & "\" & Prefix & sh.Name & ".xlsx"
            If Dir(Fname) <> "" Then Fname = Application.GetSaveAsFilename(fileFilter:="Excel Files (*.xlsx), *.xlsx)", _
                Title:=Fname & " exists - select file to save as")
            ActiveWorkbook.SaveAs Filename:=Fname, FileFormat:=51
            ActiveWorkbook.Close
        End If
     Next sh
     Application.ScreenUpdating = True
     Application.DisplayAlerts = True
End If
End Sub

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function

Open in new window

Normal-Sheet.xlsm
Excel-File-with-Table.xlsx
LVL 6
FloraAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Rgonzo1971Commented:
Hi,

pls try
Sub Split_Column_Data()
Dim LR As Long, LC As Integer, i As Long, iStart As Long, iEnd As Long
Dim Ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
Dim sh As Worksheet, Master As String, Folder As String, Fname As String
Dim loCol, loRow
If ActiveSheet.ListObjects.Count > 0 Then
    Set lo = ActiveSheet.ListObjects(1)
    loCol = Split(lo.Range.Resize(1, 1).Address, "$")(1)
    loRow = lo.Range.Resize(1, 1).Row
    If loCol > 1 Then Range("A1:" & loCol & "1").Resize(, Range("A1:" & loCol & "1").Columns.Count - 1).EntireColumn.Delete
    If loRow > 1 Then Range("A1:A" & loRow - 1).EntireRow.Delete
    
End If
On Error Resume Next
Set r = Application.InputBox("Click in the column to extract by", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
t = Now
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ActiveSheet
    Master = .Name
   LR = LastRow(ActiveSheet)
   LC = LastCol(ActiveSheet)
    .Range(.Cells(2, 1), Cells(LR, LC)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To LR
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            Sheets.Add After:=Sheets(Sheets.Count)
            Set Ws = ActiveSheet
           On Error Resume Next
            Ws.Name = .Cells(iStart, iCol).Value
            On Error GoTo 0
            Ws.Range(Cells(1, 1), Cells(1, LC)).Value = .Range(.Cells(1, 1), .Cells(1, LC)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LC)).Copy Destination:=Ws.Range("A2")
            iStart = iEnd + 1
        End If
    Next i
End With
Dim Src As Range

    For Each Ws In ActiveWorkbook.Worksheets
        With Ws
            Set Src = Ws.Range("A1").CurrentRegion
            If Src.ListObject Is Nothing Then
                .ListObjects.Add SourceType:=xlSrcRange, Source:=Src, xlListObjectHasHeaders:=xlYes
            End If
        End With
    Next Ws
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Completed in " & Format(Now - t, "hh:mm:ss.00"), vbInformation
If MsgBox("Do you want to save the separated sheets as workbooks", vbYesNo + vbQuestion) = vbYes Then
    Folder = "Select the folder to save the workbooks"
    Folder = GetDirectory(Folder)
    If Folder = "" Then Exit Sub
    Prefix = InputBox("Enter a prefix (or leave blank)")
    Application.ScreenUpdating = False
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> Master Then
            sh.Copy
            Fname = Folder & "\" & Prefix & sh.Name & ".xlsx"
            If Dir(Fname) <> "" Then Fname = Application.GetSaveAsFilename(fileFilter:="Excel Files (*.xlsx), *.xlsx)", _
                Title:=Fname & " exists - select file to save as")
            ActiveWorkbook.SaveAs Filename:=Fname, FileFormat:=51
            ActiveWorkbook.Close
        End If
     Next sh
     Application.ScreenUpdating = True
     Application.DisplayAlerts = True
End If
End Sub

Open in new window

since the table is not in a1 the code deletes the first rows and first cols if necessary

Regards
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
FloraAuthor Commented:
Thanks a million Rgonzo1971.

it worked in all scenarios except one scenario. i recorded a 5 second video. attached.

when i have first row empty it gives error.
Video.mp4
0
FloraAuthor Commented:
the error is in this line

If loCol > 1 Then Range("A1:" & loCol & "1").Resize(, Range("A1:" & loCol & "1").Columns.Count - 1).EntireColumn.Delete

Open in new window

0
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

Rgonzo1971Commented:
then try
If loCol <> "A" Then Range("A1:" & loCol & "1").Resize(, Range("A1:" & loCol & "1").Columns.Count - 1).EntireColumn.Delete
0
FloraAuthor Commented:
Thanks very much.  you are a legend Rgonzo1971
0
FloraAuthor Commented:
PERFECT!  Thanks very much
0
FloraAuthor Commented:
i posted a question for a small modification. it converts everything to table.

here is the link

https://www.experts-exchange.com/questions/29071137/VBA-modification-earlier-solution-by-Rgonzo1971.html
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VBA

From novice to tech pro — start learning today.