Data Extraction over multiple worksheets - vba

Question

I'm totally new to VBA and I'm trying to script an excel module to extract a specific section on each sheet of a workbook and format them and output together to 1 sheet on a new workbook.
So far I have this;
Public Sub extractCol()
' Find FF&E Section, Add 3 rows and Identify relevant columns.
Dim rFind As Range
With Range("A:A")
Set rFind = .Find(What:="FF&E", LookAt:=xlWhole, MatchCase:=False,
SearchFormat:=False)
If Not rFind Is Nothing Then
NumRange = rFind.Row + 3 ' Find FF&E line and add three
CRange = "C" & NumRange & ":" & "C" & NumRange + 100 ' Define First 100
Lines in Column C
ERange = "E" & NumRange & ":" & "E" & NumRange + 100 ' Define First 100
Lines in Column E
KRange = "K" & NumRange & ":" & "K" & NumRange + 100 ' Define First 100
Lines in Column K
MRange = "M" & NumRange & ":" & "M" & NumRange + 100 ' Define First 100
Lines in Column M
Set range1 = Union(Range(CRange), Range(ERange), Range(KRange),
Range(MRange)) ' Combine individual column ranges in to one selection
range1.Copy ' Copy new combined range
Set NewBook = Workbooks.Add ' Open new Workbook
ActiveCell.PasteSpecial Paste:=xlPasteValues ' Paste to new Workbook
End If
End With
End Sub
This is great as it extracts the bits that I wan't correctly but it only does the current sheet. How do I loop this to do all sheets?
Secondly I would like to paste all the results to the same sheet under one another?
And finally I have the below script that extracts the sheet name and formats it. Ideally I would like to add a column to the output above which would display this data depending on which sheet it came from.
Function FindRoom()
shtName = ActiveSheet.Name
Dim arr() As String
arr = VBA.Split(shtName, " ")
xCount = UBound(arr)
If xCount < 1 Then
FindRoom = ""
Else
FindRoom = arr(xCount)
End If
End Function
Sorry, I know this is not a simple one answer question but any help would be grateful even if it's just pointing me in the right direction.

Answer 1

Try this. I've added a worksheet variable ws. This puts the sheet name in column A of the new workbook, and the data in col B onwards. I have also added declarations for all the variables.
Public Sub extractCol()
'Find FF&E Section, Add 3 rows and Identify relevant columns.
Dim rFind As Range, CRange As String, ERange As String, KRange As String, MRange As String
Dim ws As Worksheet
Dim NewBook As Workbook
Dim NumRange As Long
Set NewBook = Workbooks.Add ' Open new Workbook
For Each ws In ThisWorkbook.Worksheets
With ws
Set rFind = .Range("A:A").Find(What:="FF&E", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not rFind Is Nothing Then
NumRange = rFind.Row + 3 ' Find FF&E line and add three
CRange = "C" & NumRange & ":" & "C" & NumRange + 100 ' Define First 100 Lines in Column C
ERange = "E" & NumRange & ":" & "E" & NumRange + 100 ' Define First 100 Lines in Column E
KRange = "K" & NumRange & ":" & "K" & NumRange + 100 ' Define First 100 Lines in Column K
MRange = "M" & NumRange & ":" & "M" & NumRange + 100 ' Define First 100 Lines in Column M
Set range1 = Union(.Range(CRange), .Range(ERange), .Range(KRange), .Range(MRange)) ' Combine individual column ranges in to one selection
range1.Copy ' Copy new combined range
NewBook.Sheets(1).Range("B" & Rows.Count).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues ' Paste to new Workbook
NewBook.Sheets(1).Range("A" & Rows.Count).End(xlUp)(2).Resize(range1.Rows.Count).Value = FindRoom(ws)
End If
End With
Next ws
End Sub
Function FindRoom(ws As Worksheet)
shtName = ws.Name
Dim arr() As String
arr = VBA.Split(shtName, " ")
xCount = UBound(arr)
If xCount < 1 Then
FindRoom = ""
Else
FindRoom = arr(xCount)
End If
End Function