Macro to copy- paste a portion of a clomun based on the text the first and last row of a range

[memo14]

Hello gentlemen,

I have a list in column A, let's say from cell A1 to A300. The list contains 16 sections, from section 1 to section 16. Each section has its own header containing the word "section" and the number of section in one cell and the name of the section. After each header there is 10 to 20 rows of text in the same column. The sections are each after each and there is no blank row in between, like this:

Section 1 - ....
....
....
....
....
....
Section 2 - ....
....
....
....
....
....
Section 3 - ....
...


Section 16 -...
...

After Section 16 there are blank rows or a cell with the text "End of sheet". The list ends here and there is nothing after in the column.
I need a macro to go through the column and copy and paste each section in a different column; let's say column B to column Q (for sections 1 to 16)

I have many of those column A of 16 section to organize. I will truly appreciate if you can help me about it.

Thank you very much, in advanced.

Memo

 

[memo14]

Hello ODIN

I could figure out why it was not working on my computer. Sometimes I have 3 asterisk before word "Section", like this:"* * * Section". In these cases it is not working, otherwise it works. So many thanks for your kindness and help. Please let me ask my questions in the future as well.

I wish you the best,

Memo

 

[=ODIN=]

It looks like there is a space after each * in your example. If that is true then use this code

Sub sectify()
    On Error Resume Next
    Dim startCol As Integer, offS As Integer, rowCount As Long
    startCol = 1
    offS = 1
    rowCount = 1
    
    For i = 1 To Cells(Rows.Count, startCol).End(xlUp).Row
        If InStr(1, Left(Cells(i, startCol).Value, 7), "section", vbTextCompare) <> 0 Or _
        InStr(1, Left(Cells(i, startCol).Value, 13), "* * * section", vbTextCompare) <> 0 Then
            rowCount = 1
            offS = offS + 1
            Cells(rowCount, offS).Value = Cells(i, startCol).Value
            rowCount = rowCount + 1
            
        
        
        ElseIf offS <> 1 Then
            Cells(rowCount, offS).Value = Cells(i, startCol).Value
            rowCount = rowCount + 1
        End If
    Next i
    
End Sub

if that is false use this code

Sub sectify()
    On Error Resume Next
    Dim startCol As Integer, offS As Integer, rowCount As Long
    startCol = 1
    offS = 1
    rowCount = 1
    
    For i = 1 To Cells(Rows.Count, startCol).End(xlUp).Row
        If InStr(1, Left(Cells(i, startCol).Value, 7), "section", vbTextCompare) <> 0 Or _
        InStr(1, Left(Cells(i, startCol).Value, 10), "***section", vbTextCompare) <> 0 Then
            rowCount = 1
            offS = offS + 1
            Cells(rowCount, offS).Value = Cells(i, startCol).Value
            rowCount = rowCount + 1
            
        
        
        ElseIf offS <> 1 Then
            Cells(rowCount, offS).Value = Cells(i, startCol).Value
            rowCount = rowCount + 1
        End If
    Next i
    
End Sub

does it work now?

 

[memo14]

Hello ODIN,

My text has spaces in between. Your code works perfectly!! Many many thanks for your help!

I have another problem to solve and share it soon.

I wish you the best,

Memo