VBA Insert blank row to split a group of cells into equal portions

hugo2502

New Member
Joined
Jul 14, 2014
Messages
3
Hi forum gurus,

I'm a novice at VBA, having started to learn it on Friday! I have 50 spreadsheets formatted the same as I'm working on now, and I've been writing code to automate the process. There's one step I can't seem to find answers for on the net.

Essentially I needed to group data when the depth jumps (which I've managed no probs, see column B). I also need to subdivide any groups more than 40 cells in a row into equal portions - I can't figure this bit out.

In the columns below, I have two examples, highlighted in column M. Group 1 has 7 cells in it, group 2 has 50 cells in it. Each group is separated by a blank row. The number of groups varies per spreadsheet, as does the length of each group. If the group is <40 continuous cells (e.g. Group 1), then it's to remain as is. If it's more than 40 cells (e.g. Group 2), split these in half by inserting a blank row after the midpoint. So, for group 2 which runs from M10-M59, insert a new row at M34 (or M35, not fussed).

To complicate things, if there are more than 80 cells, it would have to be subdivided into 3 equal sections; more than 120 cells into 4 sections etc. I've written a quick Mround formula which defines the number of segments each group would have to be divided into in column O. So Group 1 would need to be subdivided 0 times, Group 2 subdivided 1 time.

Any ideas? I'm really bogged down on this.

Thanks in advance, Hugo


B
L
M
O
1
DEPTH (M)
depth diff
CountgroupMround
2
331.01280.152470
3
331.16520.152470
4
331.31760.152470
5
331.470.152470
6
331.62240.152470
7
331.77480.304870
8
332.079612.039670
9
10
485.24160.1524501
11
485.3940.1524501
12
485.54640.1524501
13
485.69880.1524501
14
485.85120.1524501
15
486.00360.1524501
16
486.1560.1524501
17
486.30840.1524501
18
486.46080.1524501
19
486.61320.1524501
20
486.76560.1524501
21
486.9180.1524501
22
487.07042.7432501
23
489.81360.1524501
24
489.9660.1524501
25
490.11840.1524501

<tbody>
</tbody>
 
Last edited:

Some videos you may like

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying

Dendro

Active Member
Joined
Jul 3, 2014
Messages
336
Hi,
Is there other data on this sheet, not belonging to this table? I ask this if it is ok to insert a row in between the ranges? or do you want the macro to move the grouprange down each time?
 

hugo2502

New Member
Joined
Jul 14, 2014
Messages
3
Hi Dendro,
There's lots of other data in this sheet (about 21,000 rows and the remainder of the columns hidden at the moment). I've only shown two "groups", but there are hundreds.
Please insert a blank row in between the ranges. There currently is a blank row already between each of the group, but a blank row to subdivide each range would be fantastic!

Hugo
 

Dendro

Active Member
Joined
Jul 3, 2014
Messages
336

ADVERTISEMENT

Hi, i'm trying to write a code, but i'm having an error "overloop". I'm trying to fix it but maybe you or someone else can help me see where the error is.

Code:
Sub dividegroups()

Dim LastRow As Integer
Dim groupsizefirst As Double
Dim groupsizeother As Double
Dim currentrow As Integer

LastRow = Range("A" & Rows.Count).End(xlUp)

For i = 2 To LastRow
    If Cells(i - 1, 13) = "" And Cells(i - 1, 15).Value <> 0 Then
    groupsizefirst = Application.WorksheetFunction.RoundUp(Cells(i - 1, 13).Value / (Cells(i - 1, 15).Value+1), 0)
    groupsizeother = Application.WorksheetFunction.RoundDown(Cells(i - 1, 13).Value / (Cells(i - 1, 15).Value+1), 0)

    Rows(groupsizefirst + 2).EntireRow.Insert 'start counting at row 2(headers) and we want to insert the row below the first group, thus +2
    currentrow = Rows(groupsizefirst) + 3
    j = groupsizefirst
        Do While j < Cells(i - 1, 13).Value
        Rows(currentrow + groupsizeother + 1).EntireRow.Insert
        j = j + groupsizeother
        Loop
    End If
Next i

End Sub
 
Last edited:

Dendro

Active Member
Joined
Jul 3, 2014
Messages
336
nvm the above code, the logic is wrong, i'm changing the code now
 

Dendro

Active Member
Joined
Jul 3, 2014
Messages
336

ADVERTISEMENT

So here is the code with in my opinion the correct logic, but the overloop problem is not solved yet. However I'm not going to try to solve that problem before the op replies. sorry for the multi-posting
Code:
Sub dividegroups()

Dim LastRow As Integer
Dim groupsizefirst As Double
Dim groupsizeother As Double
Dim currentrow As Integer

LastRow = Range("A" & Rows.Count).End(xlUp)
lastblank = 2
For i = 2 To LastRow
    If Cells(i - 1, 13) = "" And Cells(i - 1, 15).Value = 0 Then
    lastblank = i
    End If
    If Cells(i - 1, 13) = "" And Cells(i - 1, 15).Value <> 0 Then
        With Sheets("Blad1")
        groupsizefirst = Application.RoundUp((.Cells(i - 1, 13).Value / (.Cells(i - 1, 15).Value + 1)), 0)
        groupsizeother = Application.RoundDown((.Cells(i - 1, 13).Value / (.Cells(i - 1, 15).Value + 1)), 0)
        End With
    
    Rows(lastblank + groupsizefirst + 1).EntireRow.Insert 'start counting at row 2(headers) and we want to insert the row below the first group, thus +2
    currentrow = lastblank + groupsizefirst + 2
    i = i + 1
    j = groupsizefirst
        Do While j < (Cells(i - 1, 13).Value - groupsizeother)
        Rows(currentrow + groupsizeother + 1).EntireRow.Insert
        i = i + 1
        j = j + groupsizeother
        Loop
        lastblank = i
    End If
Next i

End Sub
 

hugo2502

New Member
Joined
Jul 14, 2014
Messages
3
Hi Dendro,

Thanks for your help - unfortunately nothing happening yet?

Also, what's the code for making a dynamic sheet range. At the moment your code is:

With Sheets("Blad1")

Hugo
</pre>
 

Dendro

Active Member
Joined
Jul 3, 2014
Messages
336
found this
Code:
<code>Dim ws As Worksheet</code><code>For each ws in thisworkbook.sheets     
'do something on each worksheet 
next

</code>
 

Watch MrExcel Video

Forum statistics

Threads
1,123,135
Messages
5,599,917
Members
414,348
Latest member
KloppyM

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
Top