Extracting/copy work sheets to new workbook based on the work sheet cell text

[sahana108]

Good Morning all,

I am having master book which has more than 200+ worksheets.

I want to extract sheets which has text "Customer Name".

Currently I am using find function to identify the sheets with specific text and extracting/copy sheets to new workbook.

Can anyone help me with code, it would be very helpful.

Thanks

 

[Micron]

Your ask is a bit vague. Where the value is found
- copy each sheet to a new separate workbook, or
- copy each sheet to the same workbook but make this a new workbook, or
- copy each sheet to an existing workbook, or
- something else?

If it is to copy/extract from one wb to another, how is the target wb to be identified?
"Extract" means remove, so you want to remove the sheet to one of the above? Or just copy it?

 

[sahana108]

Hi Micron,
I need to copy the worksheets to new workbook, based on if the work sheet has the specified text "customer name" from all the work sheets.

 

[Micron]

This took me hours, sad to say, as I'm a novice with xl code. The biggest hurdle was trying to get names from a collection and use them in the copying. Just got errors. Then I thought, why not just add the sheets to the collection?
Note:
- change what the Find is looking for (I used 1) and change the file path for the new wb.
- you may get screen flicker, although I've tried to avoid that.
- this does not test if the wb name you'll use already exists
- you may get a security warning if a sheet contains an activex control.

Sub FindAndCopy()
Dim wbNew As Workbook, ws As Worksheet
Dim rng As Range
Dim col As New Collection
Dim sht As Worksheet

On Error GoTo errHandler
For Each ws In ThisWorkbook.Worksheets
    Set rng = ws.Cells.Find(What:="1", LookIn:=xlValues, Lookat:=xlWhole)
    If Not rng Is Nothing Then col.Add ws
Next

Set wbNew = Workbooks.Add(1)
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .EnableEvents = False
End With

wbNew.SaveAs Filename:="C:\Users\Micron\Documents\Excel\001Test.xlsx", FileFormat:=51
For Each sht In col
    Set ws = sht
    ws.Copy After:=wbNew.Sheets(wbNew.Sheets.count)
Next
wbNew.Sheets("Sheet1").Delete
wbNew.Sheets(1).Select
wbNew.Save

exitHere:
With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
    .EnableEvents = True
End With
Exit Sub

errHandler:
MsgBox "Error " & Err.Number & ": " & Err.Description
Resume exitHere

End Sub