using VBA to convert single tab spreadsheet to multiple spreadsheets

Hi,

I have a spreadsheet I'll be creating with provider id as the 1st column and other fields from columns 2-11.  I need to take this spreadsheet and a template spreadsheet and create new spreadsheets from the original, with the template info at the top of each of them.  The name of the new spreadsheets would be the provider #.

Working in Excel 2016.   Would love to be able to do this in batch mode if possible, as there will be a lot of spreadsheets created.

Can anyone give an approach to take that I can start with?

Thanks!

--Ben
Ben ConnerCTO, SAS developerAsked:
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.

ProfessorJimJamMicrosoft Excel ExpertCommented:
you can try this code below.  please see attached.

open the attached file then run the macro or press the Control +SHift +A to run the macro, it will ask you to select the provider column, if it is in first column then select that column and click ok. it will create seperate worksheet for every unique provider# and it will ask you whether you want them in seperate workbook. if you dont want speerate workbook simple click cancel.

try and let me know if you face any difficulties.



Sub SplitBasedOnprovider()
Dim LastRow As Long, LastCol 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
With ActiveSheet
    Master = .Name
    LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(2, 1), Cells(LastRow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To LastRow
        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, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            iStart = iEnd + 1
        End If
    Next i
End With
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 ThisWorkbook.Worksheets
        If sh.Name <> Master Then
            sh.Copy
            Fname = Folder & "\" & Prefix & sh.Name & ".xls"
            If Dir(Fname) <> "" Then Fname = Application.GetSaveAsFilename(fileFilter:="Excel Files (*.xls), *.xls)", _
                Title:=Fname & " exists - select file to save as")
            ActiveWorkbook.SaveAs Filename:=Fname, FileFormat:=56
            ActiveWorkbook.Close
        End If
     Next sh
     Application.ScreenUpdating = True
End If
End Sub

Open in new window

EE.xlsm
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
Ben ConnerCTO, SAS developerAuthor Commented:
Wow.  I couldn't even write it that fast if I had known what to do to start with.

Will give this a shot and let you know.

Thank you!

--Ben
0
ProfessorJimJamMicrosoft Excel ExpertCommented:
you are welcome. :)
0
Introduction to R

R is considered the predominant language for data scientist and statisticians. Learn how to use R for your own data science projects.

Jerry PaladinoCommented:
Professor,
I think the "GetDirectory" procedure is missing from your code to pick the location to save the new workbooks.    Code works well though once that is included.
0
ProfessorJimJamMicrosoft Excel ExpertCommented:
Jerry,

if you open the attachment which i posted along with the code, in its module "BrowseSupliment" it does contain the "GetDirectory" function.

what Ben asked can be achieved only up to the 35th line of the code, i provided extra code, in case if Ben wanted to save the sheets into separate workbooks.
0
Jerry PaladinoCommented:
My apologies...  I did not download the attachment.  Only executed the code that was in the comment block above.   Again, well done!
0
ProfessorJimJamMicrosoft Excel ExpertCommented:
no problem Jerry.

thanks.
0
Ben ConnerCTO, SAS developerAuthor Commented:
Am nearly complete creating the spreadsheet this will run against.  Looking at the code, I think I can eliminate the first half of it where it splits the single tab into multiple tabs prior to shipping them out to different spreadsheets.  I just did that in the application I wrote instead.  

Should be able to test it later today.
0
Ben ConnerCTO, SAS developerAuthor Commented:
BTW, this will end up with 4000-4500 tabs.  That won't be a problem will it?
0
ProfessorJimJamMicrosoft Excel ExpertCommented:
Hi Ben,

Number of worksheet limit is dependent upon available memory . Do you have 32 bit or 64 bit office?
0
Ben ConnerCTO, SAS developerAuthor Commented:
It's 64 bit, Excel 2016
0
Ben ConnerCTO, SAS developerAuthor Commented:
And each tab will be fairly small, about 8 columns and max 100 rows.
0
Ben ConnerCTO, SAS developerAuthor Commented:
Oh.  Wait.  I won't be running it, someone else will.  I don't know what their footprint looks like.  Oops.
0
ProfessorJimJamMicrosoft Excel ExpertCommented:
let them try, and see it might work.
0
Ben ConnerCTO, SAS developerAuthor Commented:
Just found they are on Excel 2010, 32 bit version.
0
Ben ConnerCTO, SAS developerAuthor Commented:
Trying the code above now that I have the spreadsheet created and am getting an unknown function error for GetDirectory().  I don't see it in Excel 2016.   Should I use Activeworkbook.Path or something similar?  The error was on line:

    Folder = GetDirectory(Folder)

--Ben
0
ProfessorJimJamMicrosoft Excel ExpertCommented:
Hi Ben,

yiu are getting that error because probably you did not copy the whole code from the attached workbook, please open the attached workbook that I posted in earlier post and there is also the UDF in its module "BrowseSupliment"
Once you copy and paste that code with the existing code then you will not see error
0
Ben ConnerCTO, SAS developerAuthor Commented:
Oops.  Missed the xlm attachment.  My bad.  Thanks!

--Ben
0
Ben ConnerCTO, SAS developerAuthor Commented:
Just ran the spreadsheet in debug mode.  Very nice!  The app I developed already does the first part--splitting them out into separate tabs, so I can just lift the latter half of it and let it rip.

Thanks very much!

--Ben
0
Ben ConnerCTO, SAS developerAuthor Commented:
Excellent example of splitting a sheet in a spreadsheet into multiple spreadsheets in an automated fashion.
0
ProfessorJimJamMicrosoft Excel ExpertCommented:
You are welcome Ben, I am glad I was able to help
0
Ben ConnerCTO, SAS developerAuthor Commented:
This is probably a separate question, but can this be automated?  The client wants to be able to call this in an automated .bat file.  Something like:

<path to excel>  <spreadsheet> <path to macro> <path to destination folder> <split column> <# of title rows>

I'm not even sure this is possible.  ?

--Ben
0
ProfessorJimJamMicrosoft Excel ExpertCommented:
yes it is a separate question and it not related to Excel or VBA. i suggest you open a question in the top of related window scripts .
0
Ben ConnerCTO, SAS developerAuthor Commented:
Thanks!  Will do.

--Ben
0
c4looneyCommented:
Professor,

I have 64 bit, Excel 2016 and receive a Compile error when I try to open your xslm attachment.  How do I fix that?

--Christine
0
ProfessorJimJamMicrosoft Excel ExpertCommented:
Can you please share on which line of the code the highlighter of debugger stops?  I
0
c4looneyCommented:
Hi Professor, I got busy on another project and am now back to this one.  The section highlighted is this:
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
  Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _
  As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Thank you for your help!!
0
ProfessorJimJamMicrosoft Excel ExpertCommented:
to make my the code in my answer work with both 32bit and 64bit.  the entirecode in the module called "BrowseSupliment" to be replaced with the below.

i have also uploaded the complete file.


#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
'    Dim bInfo As BROWSEINFO
'    Dim path As String
'    Dim r As Long, x As Long, pos As Integer
 
'   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

Open in new window

32bit-and-64bit-all-versions.xlsm
0
Ben ConnerCTO, SAS developerAuthor Commented:
Thanks!  I used the original code as a starting point for the project I had.  Would love to post what I developed but I don't own the code and don't have access to that system any longer.  

--Ben
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.