VBA to insert rows based on cell value compared to array

tjdickinson

Board Regular
Joined
Jun 26, 2021
Messages
61
Office Version
  1. 365
Platform
  1. Windows
After commenting on this thread, I was advised to post a new question.

I am writing a macro to insert rows in a sheet based on whether the first part of the value in colA corresponds to a certain value in an array.

Initially, I had the array fill into G3:G15 as text, then the sub compared the start of A4 to G4. If they weren't the same, then cells would be inserted above A4:F4 (so G wouldn't change). Then it checked the next row. At the end, colG was deleted.

However, it seemed very inefficient to actually populate a column, check every row, insert the cells/rows one by one, and then delete the reference column. @Trebor76 provided excellent help with this code, which does not utilise a reference column in the sheet (I've made a few small modifications; my comments are prefixed by '***):
VBA Code:
Option Explicit
Sub Macro1()

Dim strTimes() As String
Dim i As Long, j As Long
Dim TimeCheck As String
Dim rng As Range
 
strTimes = Split("8:00,8:20,9:10,10:00,10:20,11:10,12:05,12:30,13:00,13:50,14:40,15:00,15:50", ",") 'Array should just probably start at 8:20??
     '*** Rows/cells never need to be inserted before A3, so '8:00' is irrelevant.
j = 1 'This would be zero if we were checking from the first item in the 'strTimes' array
     '*** So if '8:00' is removed from the array, this should be set to 0
 
For i = 3 To 15 'Should just start at Row 4??
     '*** Yes, this should start at row 4. For complicated and unavoidable reasons, A3 is sometimes '8:00' and sometimes '8:05', so checking A3 might result in an incorrect insertion.
If i > 3 And Len(Cells(i, "A")) > 0 Then
If Left(Cells(i, "A"), 1) = "1" Or Left(Cells(i, "A"), 1) = "2" Then
TimeCheck = Left(Cells(i, "A"), 5)
Else
TimeCheck = Left(Cells(i, "A"), 4)
End If
If TimeCheck <> strTimes(j) Then
If rng Is Nothing Then
Set rng = Cells(i, "A")
Else
Set rng = Union(rng, Cells(i, "A"))
End If
i = i - 1
End If
j = j + 1
End If
 Next i
 
If Not rng Is Nothing Then
rng.EntireRow.Insert Shift:=xlDown
End If
 
End Sub

It works fine except when two rows need to be inserted next to each other. For example, in this sheet, two rows need to be inserted above row 11, whereas Trebor76's code inserts only one row.
21-22 January v8 TestR5.1234_Leerkrachten.xlsx
ABCDEF
38:05 8:20TOEZ. pauze
48:20 9:10WIS 1A2MEETING MIS
59:10 10:00WIS 2A KT 2A MT-W
610:00 10:20
710:20 11:10WIS 2A KT 2A MT-WWIS 2A KT 2A MT-W
811:10 12:00WIS 2A KT 2A MT-WWIS 1A2
912:05 12:30MEETING Lunch
1012:30 14:40
1114:40 15:00TOEZ. pauze
1215:00 15:50WIS 1A2
1315:50 16:40
Table 9

My original code worked for inserting the double row because it checked one row at a time. In the above example, after inserting the cells above A11:F11, the 'new' A12 still wouldn't match G12, so cells would be inserted again. I'm not quite sure how to modify Trebor76's code to achieve this.

Thanks for any help you can give!
 

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN
CRITICAL UPDATE

Game changer: an update to the software exporting the file has changed the way it imports to Excel. On the one hand, it should make things better in the long run, but on the other hand, it means rethinking this whole process. It doesn't seem like it should be that difficult, but I'm still a bit stumped.
  • Now it always shows the break rows, so these aren't combined with unoccupied hours.
    • In the end, the break rows should always be in rows 3, 6, 10, and 13.
    • Sometimes the whole row B:F is merged with the text 'pauze':
      21-22 January v9a Test w no lunch meetingR3.2761_Leerkrachten.xlsx
      ABCDEF
      38:00 8:20pauze
      Table 1

      But sometimes the row is interrupted by one or more supervision assignments ('Toez. pauze'):
      21-22 January v9a Test w no lunch meetingR3.2761_Leerkrachten.xlsx
      ABCDEF
      610:00 10:20TOEZ. pauzepauze
      Table 1
    • The word 'pauze' seems to always be associated with colD; if the supervision assignment is in colD, the word 'pauze' does not appear:
      21-22 January v9a Test w no lunch meetingR3.2761_Leerkrachten.xlsx
      ABCDEF
      1012:30 13:00TOEZ. pauze
      Table 1
  • If the break is preceded or followed by an empty row, that row is merged B:F, and the two rows in colA are merged together:
    21-22 January v9a Test w no lunch meetingR3.2761_Leerkrachten.xlsx
    ABCDEF
    38:00 9:10pauze
    4
    Table 5

    and:
    21-22 January v9a Test w no lunch meetingR3.2761_Leerkrachten.xlsx
    ABCDEF
    912:00 15:00
    10pauze
    11
    12pauze
    Table 5
  • I've already set a function to unmerge colA Range("A3:A15").UnMerge.
The good news is that because the break rows are added, fewer rows need to be inserted, and in relatively predictable places: only when the person has two completely free periods across the whole week. In the above example, that's row 11. There should be two rows between the 'pauze' in row 10 and the 'pauze' in row 12.

The problem is that I can't figure out how to identify where to insert the rows. ColA isn't always blank (ex. if the person has supervision in the preceding break), and there are other blank cells in colA, so I can't use empty cells as an identifier. The word 'pauze' doesn't always exist in the break rows (ex. if the person has supervision on Wednesday), so I can't search for it in rows 3, 6, 10, and 13.

So, I'm a bit stumped. Any help would be tremendously appreciated. Thank you!
 
Upvote 0
I think I figured out a solution, but I'll leave this thread open a bit longer in case someone else has a better idea. It works so far, but I'm not positive it won't break in the future if the data is slightly different from my test case.

VBA Code:
Sub insertRows()

Range("A3:A15").UnMerge

Dim a As Range, b As Range
Dim rNum As Integer
Dim rVal As String

Set a = Range("A4:F15")

For Each b In a.Rows
    If Application.WorksheetFunction.CountIf(b, "pauze") <> 0 Or Application.WorksheetFunction.CountIf(b, "TOEZ. pauze") <> 0 Then
        rNum = b.Row
        rVal = "pauze"
        If rNum <> 6 And rNum <> 10 And rNum <> 13 Then
            Application.DisplayAlerts = False
            b.Insert shift:=xlDown
            Application.DisplayAlerts = True
        End If
    End If
Next
  
End Sub
 
Upvote 0
Solution

Forum statistics

Threads
1,223,952
Messages
6,175,596
Members
452,657
Latest member
giadungthienduyen

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