VBA to insert rows based on cell value compared to array

[tjdickinson]

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 '***):

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
	A	B	C	D	E	F
3	8:05 8:20			TOEZ. pauze
4	8:20 9:10			WIS 1A2		MEETING MIS
5	9:10 10:00					WIS 2A KT 2A MT-W
6	10:00 10:20
7	10:20 11:10	WIS 2A KT 2A MT-W				WIS 2A KT 2A MT-W
8	11:10 12:00			WIS 2A KT 2A MT-W		WIS 1A2
9	12:05 12:30	MEETING Lunch
10	12:30 14:40
11	14:40 15:00	TOEZ. pauze
12	15:00 15:50	WIS 1A2
13	15: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!

 

[tjdickinson]

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
    	A	B	C	D	E	F
    3	8:00 8:20	pauze
    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
    	A	B	C	D	E	F
    6	10:00 10:20		TOEZ. pauze	pauze
    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
    	A	B	C	D	E	F
    10	12:30 13:00			TOEZ. 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
  	A	B	C	D	E	F
  3	8:00 9:10	pauze
  4
  Table 5

  
  and:
  

  21-22 January v9a Test w no lunch meetingR3.2761_Leerkrachten.xlsx
  	A	B	C	D	E	F
  9	12:00 15:00
  10		pauze
  11
  12		pauze
  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!

 

[tjdickinson]

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.

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