Oh.., okay then!

Sub Sheet2To5To1_v3()
Dim lNextRow&, lLastRow&, n&, rng, vPrds, vP, iPos%
Dim wksTarget As Worksheet, wks, vEvents, vCalcMode, vDisplay

Const sPrdID$ = "A:D,B:E,C:G,D:H,E:I,F:K,G:L,H:M,I:O,J:P,K:Q"

Set wksTarget = ActiveSheet
With wksTarget
'Get the current last row of data
lNextRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With 'wksTarget

With Application
vEvents = .EnableEvents: .EnableEvents = False
vCalcMode = .Calculation: .Calculation = xlCalculationManual
vDisplay = .ScreenUpdating: .ScreenUpdating = False
End With 'Application

vPrds = Split(sPrdID, ",")
For Each wks In ActiveWorkbook.Worksheets
If Not wks Is wksTarget Then
lLastRow = wks.Cells(wks.Rows.Count, "K").End(xlUp).Row
iPos = 1
For Each rng In wks.Range("K2:K" & lLastRow)
If rng.Value 0 Then
lNextRow = lNextRow + 1
With wksTarget
'Set RowHeight for the 1st row of each wks data.
'then reset the trigger to skip subsequent rows.
If iPos 0 Then .Rows(lNextRow).RowHeight = 24: iPos = 0
.Cells(lNextRow, "A") = wks.Cells(rng.Row, "A")
For n = LBound(vPrds) To UBound(vPrds)
vP = Split(vPrds(n), ":")
If Right(wks.Cells(rng.Row, "C"), 1) = vP(0) Then
.Cells(lNextRow, vP(1)) = wks.Cells(rng.Row, "K")
Exit For
End If
Next 'n
.Cells(lNextRow, "S") = wks.Cells(rng.Row, "E")
End With 'wksTarget
End If 'Not rng.Value = 1
Next 'rng
End If 'Not wks = wksTarget
Next 'wks

With Application
.EnableEvents = vEvents
.Calculation = vCalcMode
.ScreenUpdating = vDisplay
End With 'Application
End Sub

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion