select lines from multiple worksheets and write to new worksheet

R

rem

I need to select certain lines from multiple worksheets (based on a field
value) and create a new worksheet containing all the lines. Any help would be
appreciated.
 
B

Bernie Deitrick

Rem,

Try the sub below. The assumptions are: all your data sheets have the same layout, with headers in
row 1 and data starting in row 2, and the key value is always in the same column on each sheet.

HTH,
Bernie
MS Excel MVP

Sub ExtractDataFromMultipleSheets()

Dim myCell As Range
Dim mySht1 As Worksheet
Dim mySht2 As Worksheet
Dim myKey As Variant
Dim myKeyCell As Range
Dim myArea As Range
Dim myCol As Integer

On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Extract").Delete
Application.DisplayAlerts = True
Set mySht1 = Worksheets.Add(Before:=Sheets(1))
mySht1.Name = "Extract"

Set myKeyCell = Application.InputBox( _
"Select a cell with the extract value", , , , , , , 8)
myKey = myKeyCell.Text
myCol = myKeyCell.Column


For Each mySht2 In ActiveWorkbook.Worksheets
If mySht2.Name <> mySht1.Name Then
mySht2.Activate
Set myArea = mySht2.Cells(1, myCol).CurrentRegion

With myArea
.AutoFilter Field:=myCol - myArea.Column + 1, Criteria1:=myKey
.Offset(1, 0).Resize(myArea.Rows.Count - 1, .Columns.Count). _
SpecialCells(xlCellTypeVisible).Copy _
mySht1.Range("B65536").End(xlUp)(2)
mySht1.Range(mySht1.Range("A65536").End(xlUp)(2), _
mySht1.Range("B65536").End(xlUp)(1, 0)).Value = mySht2.Name
.AutoFilter
End With
End If
Next mySht2
mySht1.Columns.AutoFit
End Sub
 
Top