?
Solved

slicing and dicing worksheets into spearate excel workbooks

Posted on 2008-02-01
18
Medium Priority
?
361 Views
Last Modified: 2012-05-05
Hi,

I've three workbooks a.xls., b.xls, c.xls, each contains 50-60 sheets,

the name of each sheet corresponds to a salesperson

I need to group each salesperson into a separate workbook in vba

all salespeople are in  workbook a.xls and b.xls but only a few are in c.xls

so for example of

in a.xls I've got
Salesperson1
Salesperson2
Salesperson3

in b.xls I've got
Salesperson1
Salesperson2
Salesperson3
 
in c.xls I've got
Salesperson1


What  I need to create is

a workbook call salesperson1 which has three sheets
a.xls.Salesperson1
b.xls.Salesperson1
c.xls.Salesperson1

a workbook call salesperson2 which has three sheets
a.xls.Salesperson2
b.xls.Salesperson2


a workbook call salesperson3 which has three sheets
a.xls.Salesperson3
b.xls.Salesperson3

Any help would be much appreciated.
Regards,
linnanda


0
Comment
Question by:LINNANDA
  • 10
  • 8
18 Comments
 
LVL 33

Expert Comment

by:Robberbaron (robr)
ID: 20806570
so will you end up with 50 workbooks with 3 sheets(a,b,c) or one workbook with 50 sheets
0
 
LVL 33

Expert Comment

by:Robberbaron (robr)
ID: 20806865
try this in each of your master workbooks. ie A, B, C

run the CopySheets macro for each.

If this is the correct format, we can try to automate selecting master and running macro.
Sub CopySheets()
 
'macro by RobberBaron.  EE.  2/Feb/2008
 
    Dim oSht As Worksheet
    Dim oWb As Workbook, oWrkDest As Workbook
    Dim sShtName As String, oWbName As String
    
    oWbName = ActiveWorkbook.Name
    
    For Each oSht In ActiveWorkbook.Sheets
        'get workbook name
        sShtName = oSht.Name
        'see if destination workbook open
        For Each oWb In Application.Workbooks
            If UCase(oWb.Name) = UCase(sShtName & ".xls") Then
                'found it
                Exit For
            End If
        Next oWb
        If oWb Is Nothing Then
            'need to open
            On Error Resume Next
            Application.Workbooks.Open FileName:=sShtName & ".xls", Editable:=True
            If Err.Number = 1004 Then
                'not found so create
                On Error GoTo 0
                Application.Workbooks.Add      'should return wb but doesnt in XL97
                Set oWb = ActiveWorkbook
                oWb.SaveAs FileName:=sShtName & ".xls"
            End If
            
 
        End If
        'copy before sheet 1 in desination
        oSht.Copy Before:=oWb.Sheets(1)
    Next oSht
End Sub

Open in new window

0
 
LVL 33

Expert Comment

by:Robberbaron (robr)
ID: 20806910
update to fix naming of output sheets
Sub CopySheets()
'
' Macro by RobberBaron   EE  2/Feb/2008
'v 2
 
'
    Dim oSht As Worksheet, i As Integer
    Dim oWb As Workbook, oWrkDest As Workbook
    Dim sShtName As String, sWbName As String
    
    sWbName = ActiveWorkbook.Name      'this gives name incl .XLS
    i = InStr(1, sWbName, ".")
    sWbName = Left(sWbName, i - 1)
    
    For Each oSht In ActiveWorkbook.Sheets
        'get workbook name
        sShtName = oSht.Name
        'see if destination workbook open
        For Each oWb In Application.Workbooks
            If UCase(oWb.Name) = UCase(sShtName & ".xls") Then
                'found it
                Exit For
            End If
        Next oWb
        If oWb Is Nothing Then
            'need to open
            On Error Resume Next
            Application.Workbooks.Open FileName:=sShtName & ".xls", Editable:=True
            If Err.Number = 1004 Then
                'not found so create
                On Error GoTo 0
                Application.Workbooks.Add      'should return wb but doesnt in XL97
                Set oWb = ActiveWorkbook
                oWb.SaveAs FileName:=sShtName & ".xls"
            End If
            
 
        End If
        'need to temp name sheet as the workbook name before copy
        oSht.Name = sWbName       'set name for destination
        oSht.Copy Before:=oWb.Sheets(1)     'copy sheet to destination
        oSht.Name = sShtName   'set back to correct name
    Next oSht
End Sub

Open in new window

0
[Webinar] Improve your customer journey

A positive customer journey is important in attracting and retaining business. To improve this experience, you can use Google Maps APIs to increase checkout conversions, boost user engagement, and optimize order fulfillment. Learn how in this webinar presented by Dito.

 

Author Comment

by:LINNANDA
ID: 20824393
Hi robberbaron,

The name of the files are outputing correctly but only a sheet from one of the workbooks is populating the new workbooks.  

The macro that is running the code is being called from a separate workbook with three sheets so what I getting is

b.xls/ Sheet1/sheet2/sheet3

in each workbook, I think it would be better if I called the workbook explicitly?
0
 
LVL 33

Expert Comment

by:Robberbaron (robr)
ID: 20827843
yes.

The way i wrote the code, it is attached to each & every source workbook and run for each. ie 3 times.

to run from a master macro is quite easy but a few changes need to be made.

roughly

set wbAction=workbooks("WB1.xls")
CopySheet (wbAction)


and in CopySheet, change all ActiveWorkbook to be wbAction.

i'll be able to give better code tonight.

0
 

Author Comment

by:LINNANDA
ID: 20832324
Hi

I tired this but am getting the wrong number of arguements on   CopySheets (wbAction)

       
Sub CopySheets()

'
' Macro by RobberBaron   EE  2/Feb/2008
'v 2
 
'
    Dim oSht As Worksheet, i As Integer
    Dim oWb As Workbook, oWrkDest As Workbook
    Dim sShtName As String, sWbName As String
   
    sWbName = wbAction.Name      'this gives name incl .XLS
    i = InStr(1, sWbName, ".")
    sWbName = Left(sWbName, i - 1)
   
    For Each oSht In wbAction.Sheets
        'get workbook name
        sShtName = oSht.Name
        'see if destination workbook open
        For Each oWb In Application.Workbooks
            If UCase(oWb.Name) = UCase(sShtName & ".xls") Then
                'found it
                Exit For
            End If
        Next oWb
        If oWb Is Nothing Then
            'need to open
            On Error Resume Next
            Application.Workbooks.Open Filename:=sShtName & ".xls", Editable:=True
            If Err.Number = 1004 Then
                'not found so create
                On Error GoTo 0
                Application.Workbooks.Add      'should return wb but doesnt in XL97
                Set oWb = wbAction
                oWb.SaveAs Filename:=sShtName & ".xls"
            End If
           
 
        End If
        'need to temp name sheet as the workbook name before copy
        oSht.Name = sWbName       'set name for destination
        oSht.Copy Before:=oWb.Sheets(1)     'copy sheet to destination
        oSht.Name = sShtName   'set back to correct name
    Next oSht

End Sub


Sub test()

  Set wbAction = Workbooks("C:\a.xls")
    CopySheets (wbAction)

End Sub
0
 
LVL 33

Expert Comment

by:Robberbaron (robr)
ID: 20836674
1/ change to  
Sub CopySheets( wbAction )


2/ also change to...
                Application.Workbooks.Add      'should return wb but doesnt in XL97
                Set oWb = ActiveWorkBook     'add returns new as activeworkbook
                oWb.SaveAs Filename:=sShtName & ".xls"

0
 

Author Comment

by:LINNANDA
ID: 20839410
Hi robberbaron,

Applied these changes, ran the test macro and got

Run-time error '9'

Subscript out of range

on

Set wbAction = Workbooks("C:\a.xls")

I also need to add b.xls and c.xls into this script.
0
 
LVL 33

Expert Comment

by:Robberbaron (robr)
ID: 20839955
update.

put this code in your master workbook.

it opens each source workbook and copies sheets to destination workbooks
Sub Master()
    Dim oWb As Workbook
    
    ChDir ActiveWorkbook.Path
    
    Set oWb = GetWorkBook("WB_A")
        CopySheets oWb
        oWb.Close False   'close without saving
        
        
    Set oWb = GetWorkBook("WB_B")
        CopySheets oWb
        oWb.Close False   'close without saving
 
    Set oWb = GetWorkBook("WB_C")
        CopySheets oWb
        oWb.Close False   'close without saving
    
End Sub
 
Function GetWorkBook(sWbname As String) As Workbook
    Dim oWb As Workbook
        For Each oWb In Application.Workbooks
            If UCase(oWb.Name) = UCase(sWbname & ".xls") Then
                'found it
                Set GetWorkBook = oWb
                Exit For
            End If
        Next oWb
        If oWb Is Nothing Then
            'need to open
            On Error Resume Next
            Application.Workbooks.Open FileName:=sWbname & ".xls", Editable:=True
            If Err = 0 Then
                Set GetWorkBook = ActiveWorkbook
            End If
        End If
End Function
 
Sub CopySheets(wbActive As Workbook)
'
' Macro RobberBaron   EE  2/Feb/2008
'v 2
 
'
    Dim oSht As Worksheet, i As Integer
    Dim oWb As Workbook, oWrkDest As Workbook
    Dim sShtName As String, sWbname As String
    
    sWbname = wbActive.Name      'this gives name incl .XLS
    i = InStr(1, sWbname, ".")
    sWbname = Left(sWbname, i - 1)
    
    For Each oSht In wbActive.Sheets
        'get workbook name
        sShtName = oSht.Name
        'see if destination workbook open
        For Each oWb In Application.Workbooks
            If UCase(oWb.Name) = UCase(sShtName & ".xls") Then
                'found it
                Exit For
            End If
        Next oWb
        If oWb Is Nothing Then
            'need to open
            On Error Resume Next
            Application.Workbooks.Open FileName:=sShtName & ".xls", Editable:=True
            If Err.Number = 1004 Then
                'not found so create
                On Error GoTo 0
                Application.Workbooks.Add      'should return wb but doesnt in XL97
                Set oWb = ActiveWorkbook
                oWb.SaveAs FileName:=sShtName & ".xls"
            End If
            
 
        End If
        'need to temp name sheet as the workbook name before copy
        oSht.Name = sWbname        'set name for destination
        oSht.Copy Before:=oWb.Sheets(1)   'copy sheet to destination
 
        oSht.Name = sShtName  'set back to correct name
    Next oSht
End Sub

Open in new window

0
 

Author Comment

by:LINNANDA
ID: 20840609
Hi,
 

I ran this macro from Sub Master()

and got Run-time error '91'

Object variable or With block variable not sent

when I hit the debug button it hightlighted

sWbname = wbActive.Name      'this gives name incl .XLS

0
 
LVL 33

Expert Comment

by:Robberbaron (robr)
ID: 20840847
the only macro you should run is Master()

it's not opening the desired workbook. ie named WB_A.xls

some error check attached. Replace master() code
Sub Master()
    Dim oWb As Workbook, sTmp
    
    ChDir ActiveWorkbook.Path
    
    sTmp = "WB_A"
    Set oWb = GetWorkBook(sTmp)
    If oWb Is Nothing Then
        MsgBox "Could not open " & ActiveWorkbook.Path & "\" & sTmp, vbCritical
        Exit Sub
    End If
        
        CopySheets oWb
        oWb.Close False   'close without saving
        
        
    sTmp = "WB_B"
    Set oWb = GetWorkBook(sTmp)
    If oWb Is Nothing Then
        MsgBox "Could not open " & ActiveWorkbook.Path & "\" & sTmp, vbCritical
        Exit Sub
    End If
        CopySheets oWb
        oWb.Close False   'close without saving
    
End Sub

Open in new window

0
 

Author Comment

by:LINNANDA
ID: 20841135
Hi,

Ive the three workbooks open and am getting a  Compile error :
ByRef argument type mismatch

when I run the Master macro

on

 Set oWb = GetWorkBook(sTmp)
0
 
LVL 33

Expert Comment

by:Robberbaron (robr)
ID: 20845980
works ok for me on XL97.

try changing dim to
    Dim oWb As Workbook, sTmp as string
0
 

Author Comment

by:LINNANDA
ID: 20848815
Thanks robberbaron, that worked for me on excel 2000 the only thing is that I now have 60 sheets open which I need to close and save  to C:\Reports


i 've added  oWb.Close to Sub CopySheets(wbActive As Workbook)

but doesn't seem to work



Sub CopySheets(wbActive As Workbook)
'
' Macro RobberBaron   EE  2/Feb/2008
'v 2
 
'
    Dim oSht As Worksheet, i As Integer
    Dim oWb As Workbook, oWrkDest As Workbook
    Dim sShtName As String, sWbname As String
   
    sWbname = wbActive.Name      'this gives name incl .XLS
    i = InStr(1, sWbname, ".")
    sWbname = Left(sWbname, i - 1)
   
    For Each oSht In wbActive.Sheets
        'get workbook name
        sShtName = oSht.Name
        'see if destination workbook open
        For Each oWb In Application.Workbooks
            If UCase(oWb.Name) = UCase(sShtName & ".xls") Then
                'found it
                Exit For
            End If
        Next oWb
        If oWb Is Nothing Then
            'need to open
            On Error Resume Next
            Application.Workbooks.Open Filename:=sShtName & ".xls", Editable:=True
            If Err.Number = 1004 Then
                'not found so create
                On Error GoTo 0
                Application.Workbooks.Add      'should return wb but doesnt in XL97
                Set oWb = ActiveWorkbook
                oWb.SaveAs Filename:=sShtName & ".xls"
               
                 oWb.Close
            End If
           
 
        End If
        'need to temp name sheet as the workbook name before copy
        oSht.Name = sWbname        'set name for destination
        oSht.Copy Before:=oWb.Sheets(1)   'copy sheet to destination
 
        oSht.Name = sShtName  'set back to correct name
    Next oSht
End Sub
0
 
LVL 33

Accepted Solution

by:
Robberbaron (robr) earned 2000 total points
ID: 20855973
i didnt close them as it makes it quicker to save the second and third sheets.

They are saved when first created.


at end of master()

   
    'close all except master
    For Each oWb In Application.Workbooks
        If UCase(oWb.Name) <> "MASTER.XLS" Then
            oWb.Close True
        End If
    Next oWb
0
 

Author Comment

by:LINNANDA
ID: 20865066
Hi robberbaron,

I added the code to the end of master (0 but all the excel spreadhseets which have been created are still open,

Sub Master()
    Dim oWb As Workbook, sTmp As String
   
    ChDir ActiveWorkbook.Path
   
    sTmp = "WB_A"
    Set oWb = GetWorkBook(sTmp)
    If oWb Is Nothing Then
        MsgBox "Could not open " & ActiveWorkbook.Path & "\" & sTmp, vbCritical
        Exit Sub
    End If
       
        CopySheets oWb
        oWb.Close False   'close without saving
       
       
       
       
       sTmp = "WB_B"
    Set oWb = GetWorkBook(sTmp)
    If oWb Is Nothing Then
        MsgBox "Could not open " & ActiveWorkbook.Path & "\" & sTmp, vbCritical
        Exit Sub
    End If
       
        CopySheets oWb
        oWb.Close False   'close without saving
       
       
         sTmp = "WB_C"
    Set oWb = GetWorkBook(sTmp)
    If oWb Is Nothing Then
        MsgBox "Could not open " & ActiveWorkbook.Path & "\" & sTmp, vbCritical
        Exit Sub
    End If
       
        CopySheets oWb
       oWb.Close False  'close without saving
       
       
         For Each oWb In Application.Workbooks
        If UCase(oWb.Name) <> "MASTER.XLS" Then
            oWb.Close True
        End If
    Next oWb
       

   
End Sub
0
 
LVL 33

Expert Comment

by:Robberbaron (robr)
ID: 20865609
it works for my test.

you will have to step through the macro to find why it doesnt get to the close loop
0
 

Author Comment

by:LINNANDA
ID: 20866297
Thanks robberbaron got it sorted
0

Featured Post

Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This is an addendum to the following article: Acitve Directory based Outlook Signature (http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_24950055.html) The script is fine, and works in normal client-server domains…
This script will sweep a range of IP addresses (class c only, 255.255.255.0) and report to a log the version of office installed. What it does: 1.)      Creates log file in the directory the script is run from (if it doesn't already exist) 2.)      Sweep…
In response to a need for security and privacy, and to continue fostering an environment members can turn to for support, solutions, and education, Experts Exchange has created anonymous question capabilities. This new feature is available to our Pr…
How can you see what you are working on when you want to see it while you to save a copy? Add a "Save As" icon to the Quick Access Toolbar, or QAT. That way, when you save a copy of a query, form, report, or other object you are modifying, you…
Suggested Courses

589 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question