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

memo14

New Member
Joined
Jun 5, 2014
Messages
8
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
 
Does this work?
Code:
Sub sectify()
    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, Cells(i, startCol).Value, "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
 
Upvote 0
Hello Mr./Ms. =ODIN= !

I really appreciate your attention and quick response. It works and does the main job, but there are two small issues.

First, after running the code and copy-pasting the sections, I receive the "Error 1004" and the line 13 becomes highlighted in the code:

Cells(rowCount, offS).Value = Cells(i, startCol).Value

And second, in my sheet sometimes the word "section" exists in the text under the headers; like this:

Section 3 - ....
...
for ...see section 7 ...
...
Section 4 - ...

So, the code breaks, for example, the section 3 in two columns when it reaches to the word "section" in the text.

I was wondering if these problems could be fixed.

Once again, I appreciate your help.

All the best,

Memo
</pre>
 
Upvote 0
Does this work?
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 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
 
Upvote 0
Hello again =ODIN=,

I tried the code with this new modification and it is not working.

Thanks a lot for your attempt,

Memo
 
Upvote 0
Sorry, at this point I don't know what the problem is. If you share you're workbook I can take a look, otherwise, maybe someone more advanced than I can help.
 
Upvote 0
[TABLE="width: 205"]
<tbody>[TR]
[TD]Hello =ODIN=

Let's say the list is like this including 6 sections ( in the reality 16 sections). Thank you in advanced.
Memo

Section 1 - Introduction
[/TD]
[/TR]
[TR]
[TD]o5p5n yryr rtyry76[/TD]
[/TR]
[TR]
[TD]s4 etetet[/TD]
[/TR]
[TR]
[TD]dddd5 rtret[/TD]
[/TR]
[TR]
[TD]Section 2 - Water quality[/TD]
[/TR]
[TR]
[TD]dd6 wetw wtyt5[/TD]
[/TR]
[TR]
[TD]ff7rthry[/TD]
[/TR]
[TR]
[TD]Section 3 - Air qualiy gwfqrq[/TD]
[/TR]
[TR]
[TD]ggrtet reyre[/TD]
[/TR]
[TR]
[TD]gg9 see Section 7 for more detail[/TD]
[/TR]
[TR]
[TD]gerte eter eet[/TD]
[/TR]
[TR]
[TD]grtet ryeyey[/TD]
[/TR]
[TR]
[TD]Section 4 - Soil quality sdgsgdsg[/TD]
[/TR]
[TR]
[TD][py eryyy[/TD]
[/TR]
[TR]
[TD]ryry 0 - See Section 10 for …[/TD]
[/TR]
[TR]
[TD]ytryyreueu[/TD]
[/TR]
[TR]
[TD]Section 5 - gfsgsg sdgsg sdgsdg[/TD]
[/TR]
[TR]
[TD]y eyey eryete qweq[/TD]
[/TR]
[TR]
[TD]rwr t[/TD]
[/TR]
[TR]
[TD]Section 6 - ggegery tjghoi reeyrw y4[/TD]
[/TR]
[TR]
[TD]phjrh eyeyr[/TD]
[/TR]
[TR]
[TD]erye eyeyr[/TD]
[/TR]
[TR]
[TD]nn trhrthrth thrthhh[/TD]
[/TR]
[TR]
[TD]Worksheet End[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
 
Upvote 0
Sorry, after putting your data into column A and testing the macro on my pc using excel version 2007, it works just fine for me. I have no idea why it is not workiing for you.
 
Upvote 0

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top