Hi Howard,

Am Mon, 26 Oct 2015 08:35:45 +0100 schrieb Claus Busch:

https://onedrive.live.com/redir?resi...=folder%2cxlsm

or try it this way (macro also at OneDrive in your workbook Module3):

Sub CopyAreas()
Dim LRow As Long, i As Long, n As Long
Dim varFirst() As Variant, varLast() As Variant
Dim rngC As Range, myRng As Range

With Sheets("Main")
LRow = .Cells(Rows.Count, 2).End(xlUp).Row
'Writing the last row of the areas in an array
For Each rngC In .Range("B1:B" & LRow +
1).SpecialCells(xlCellTypeBlanks)
ReDim Preserve varLast(i)
varLast(i) = rngC.Row - 1
i = i + 1
Next
'Writing the first row of the areas in an array
ReDim Preserve varFirst(UBound(varLast))
varFirst(n) = 2
For i = LBound(varLast) To UBound(varLast) - 1
n = n + 1
varFirst(n) = varLast(i) + 3
Next
'Copying the areas
For i = LBound(varFirst) To UBound(varFirst)
Set myRng = .Range(.Cells(varFirst(i), 2), .Cells(varLast(i),
5))
Sheets(.Cells(varFirst(i) - 1, 1).Value).Cells(Rows.Count,
1).End(xlUp)(2) _
.Resize(myRng.Rows.Count, 4).Value = myRng.Value
Next
End With
End Sub


Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional