Moving Worksheets to a new Workbook

[termeric]

Hello, I am trying to move a group of worksheets to a new workbook. I have the code working when I hard code the worksheet names in the code, but I want to make those variables that will be filled by values on one of the worksheets, so that this can be run for different groups.

This is the original code that works;

Sub Seperate_Sheets()

Dim Path1 As String

Path1 = ActiveWorkbook.Path & "\" & "Tracker 1"

Sheets(Array("sheet1", "sheet2", "sheet3")).Move
    ActiveWorkbook.SaveAs Filename:=Path1, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close

End Sub

This is the code that I have incorporated it into, where I build the array based on the team selected;

Sub newMovement()

Dim ExDir As String
Dim Managers() As String
Dim MgrCount As Integer
Dim r As Integer, lr As Integer, ldir As Integer, o As Integer


o = 1
lr = Sheets("Swap").UsedRange.Rows.Count
ldir = Sheets("Directory").UsedRange.Rows.Count
ExDir = Sheets("Control").Range("A2").Value
MgrCount = 0

'determing how many managers are on each team
For r = 2 To lr
    If ExDir = Sheets("Swap").Range("A" & r).Value Then
        MgrCount = Sheets("Swap").Range("b" & r).Value
    End If
Next r

'size array
ReDim Managers(MgrCount) As String

'build list of managers on selected team
For r = 1 To ldir
    If Sheets("Directory").Range("h" & r).Value = ExDir Then
        Managers(o) = Sheets("Directory").Range("a" & r).Value
        o = o + 1
    End If
Next r

'move report tabs to new workbook
Sheets(array(Managers()).Move
    ActiveWorkbook.SaveAs Filename:=Path1, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close

End Sub

I'm not sure what the proper syntax is to use the Managers() array, do I need to write another loop, or is there another way to just say use everything in here?

 

[Fluff]

How about

Sub termeric()
   Dim Cl As Range
   Dim ExDir As Variant
   Dim Ws As Worksheet
   
   Set Ws = Sheets("Directory")
   ExDir = Sheets("Control").Range("A2").Value

   With CreateObject("scripting.dictionary")
      For Each Cl In Ws.Range("A2", Ws.Range("A" & Rows.Count).End(xlUp))
         If Cl.Offset(, 7).Value = ExDir Then .item(Cl.Value) = Empty
      Next Cl
      Sheets(.keys).Move
      ActiveWorkbook.SaveAs FileName:=Path1, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
      ActiveWindow.Close
   End With
End Sub

You will need to assign a value to the Path1 variable

 

[termeric]

This works great, thank you. one question though, how would I trim the name that I am entering into the array? I've discovered that some of my teams are too long to be a worksheet name, so I want to take the left 25 characters.

I tried this, and it didn't work

If Cl.Offset(, 7).Value = ExDir Then Left(.Item(Cl.Value), 25) = Empty

I haven't used the scripting.dictionary before so I'm not sure where to do this

thank you

 

[Fluff]

It would need to be

.item(left(Cl.Value,25))

But it will need to exactly match the sheet name

 

[termeric]

Hi Fluff, one more question for you, how would I add one more item to the scripting that is the same every time? So after I loop through the variable list, I can also pick up the "overview" page?

 

[Fluff]

Simply add this line

Next Cl
[COLOR=#0000ff].Add "overview", Nothing[/COLOR]
Sheets(.keys).Move

 

[termeric]

thanks, I got it to work with this, but I figured there had to be a better way.


If Cl.Offset(, 7).Value = ExDir Then .Item("overview") = Empty