Copy worksheets based on column value - vba

Question

I am fairly new with Excel vba but have been using access vba for some time now.
I have some code which splits a main file into several other files based on a distinct column in excel
Sub SplitbyValue()
Dim FromR As Range, ToR As Range, All As Range, Header As Range
Dim Wb As Workbook
Dim Ws As Worksheet
'Get the header in this sheet
Set Header = Range("D8").EntireRow
'Visit each used cell in column D, except the header
Set FromR = Range("D9")
For Each ToR In Range(FromR, Range("D" & Rows.Count).End(xlUp).Offset(1))
'Did the value change?
If FromR <> ToR Then
'Yes, get the cells between
Set All = Range(FromR, ToR.Offset(-1)).EntireRow
'Make a new file
Set Wb = Workbooks.Add(xlWBATWorksheet)
'Copy the data into there
With Wb.ActiveSheet
Header.Copy .Range("A8")
All.Copy .Range("A9")
End With
'Save it
Wb.SaveAs ThisWorkbook.Path & "\" & Format(Date, "yyyy.mm.dd") & _
" - " & FromR.Value & ".xls", xlWorkbookNormal
Wb.Close
'Remember the start of this section
Set FromR = ToR
End If
Next
End Sub
This works great for the main sheet, but have to copy multiple tabs and this only captures one sheet. How can I expand this so it copies the other sheets as well into that file?
example:
ColumnA
Id1
Id2
Id3
This creates three files (Id1)(Id2)(Id3) but ignores the other sheets.

Answer 1

Create an encompassing loop and define the worksheet being processed with a With...End With statement. You loop through a For Each...Next Statement using a Worksheet object on the Worksheets collection but I typically use the index of each worksheet.
Sub SplitbyValue()
Dim FromR As Range, ToR As Range, dta As Range, hdr As Range
Dim w As Long, ws As Worksheet, wb As Workbook, nuwb As Workbook
'Get the header in this sheet
Set wb = ActiveWorkbook
For w = 1 To wb.Worksheets.Count
With wb.Worksheets(w)
Set hdr = .Range(.Cells(8, "D"), .Cells(8, Columns.Count).End(xlToLeft))
'Visit each used cell in column D, except the header
Set FromR = .Range("D9")
For Each ToR In .Range(FromR, .Range("D" & Rows.Count).End(xlUp).Offset(1))
'Did the value change?
If FromR <> ToR Then
'Yes, get the cells between
Set dta = .Range(FromR, ToR.Offset(-1)).EntireRow
'Make a new file
Set nuwb = Workbooks.Add(xlWBATWorksheet)
'Copy the data into there
With nuwb.Sheet1
hdr.Copy .Range("A8")
dta.Copy .Range("A9")
End With
'Save it
nuwb.SaveAs ThisWorkbook.Path & "\" & Format(Date, "yyyy.mm.dd") & _
" - " & FromR.Value & ".xls", xlWorkbookNormal
nuwb.Close False
Set nuwb = Nothing
'Remember the start of this section
Set FromR = ToR
End If
Next ToR
End With
Next w
End Sub
I did not set up a full test environment but this should get you heading in the right direction. I've always found it unreliable to depend on ActiveSheet.

Answer 2

Here is a function that will allow you to search for a sheet and goto it by name.
Private Sub loopsheets(strSheetName As String)
iFoundWorksheet = 0
For iIndex = 1 To ea.ActiveWorkbook.Worksheets.Count
Set ws = ea.Worksheets(iIndex)
If UCase(ws.Name) = UCase(strSheetName) Then
iFoundWorksheet = iIndex
Exit For
End If
Next iIndex
If iFoundWorksheet = 0 Then
MsgBox "No worksheet was found with the name RESULTS (this is not case sensetive). Aborting."
End If
Set ws = ea.Worksheets(iFoundWorksheet)
ws.Activate
End Sub
If you want to just loop them all you just need the for loop.
Dim iIndex as Integer
For iIndex = 1 To ea.ActiveWorkbook.Worksheets.Count
Set ws = ea.Worksheets(iIndex)
ws.Activate
'Call your code here.
SplitbyValue
Next iIndex