vba code to find a predetermined range, copy and transpose - excel

Question

I'm working on a excel document with multiple seperate data, all in a single column (A1 to A10160).
All the data begins in a cell with the text NC/xx/xxxx/x (x being variable) and ending in a cell containing different dates but the cell above it always has the text "Start Date". Some data covers 49 cells others cover 51 cells so it's not contained in a fixed number of cells in the column.
I need to copy the range from NC/xx/xxxx/x to Start Date plus one for each data "set", transpose it and paste all the data in the column in a new sheet.
Really haven't found anything useful so far but I am fumbling with this one:
Sub Find()
Dim Search, End, Start, i As Integer, j As Integer, L
Search = Cells(1, 1)
End = Cells(2, 1)
For i = 1 To 10160
If Left(Cells(i, 1), 3) = Search Then
Start = i - 0
End If
Next i
For j = 1 To 10160
If Cells(j, 1) = End Then
L = j + 1
End If
Sheet4.Select
Range(Cells(Start, 1), Cells(L + 2, 1)).Select
Selection.Copy
Sheet4.Range("BB23").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
End
Next j
End Sub
Would really appreciate any help I can get!
Thanks!

Answer 1

It looks like you haven't had much interest in your question, so I've taken a look at it. It's one of those fiddly jobs - not terribly technical but tricky to get the flow of logic right. The code below gives you what you've outlined in your question. You've said transpose it - so that's what the code does. Try it and let me know how you go.
Option Explicit
Sub Copy2Sheet2()
'Declare all your variables
Dim ws1 As Worksheet, ws2 As Worksheet
Dim topRow As Long, BottomRow As Long, LastRow As Long
Dim PasteToRow As Long, i As Long, c As Range
'Set the sheet variables
Set ws1 = Sheets(1)
Set ws2 = Sheets(2)
'Initial row settings
LastRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
PasteToRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1 '<~~ assumes headers on sheet2
'Start the loop
For i = 1 To LastRow
'Find the bottom row of the first block of data
Set c = ws1.Range("A" & i & ":A" & LastRow).Find(What:="Start Date", LookIn:=xlValues)
BottomRow = c.Row + 1
'Define and copy the range to sheet2
ws1.Range("A" & i & ":A" & BottomRow).Copy
ws2.Range("A" & PasteToRow).PasteSpecial Transpose:=True
Application.CutCopyMode = False
'Redefine the 'paste to' row
PasteToRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
'Redefine the top row of the next block of data
i = BottomRow
'Repeat the process
Next i
End Sub