Create a vba code to insert row based on two-column condition

[Ganeshan]

Hi Everyone,
I am new to this forum and have been trying to learn some VBA coding to automate some data. My question is -

I would like to insert a row when there is a value change in two-column cells in an excel
For example, columns F and G where F has a string value of "Buy" and "Sell" and column G has string "D" and "S".

My code should add a row when the column is sorted the last value is
"Buy" - "D"
"Buy" - "S"
"Sell" - "D"
"Sell" - "S"

 

[Trebor76]

Hi Ganeshan,

Welcome to MrExcel!!

Try this:

Option Explicit
Sub Macro1()

    Dim wsSrc As Worksheet
    Dim lngLastRow, lngRow As Long
    Dim strKey As String
   
    Application.ScreenUpdating = False
   
    Set wsSrc = ThisWorkbook.Sheets("Sheet1") '<- Sheet name containing the data. Change to suit if necessary.
    lngLastRow = wsSrc.Range("F:G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   
    For lngRow = lngLastRow To 3 Step -1
        If Len(strKey) = 0 Then
            strKey = wsSrc.Range("F" & lngRow) & wsSrc.Range("G" & lngRow)
        End If
        If wsSrc.Range("F" & lngRow - 1) & wsSrc.Range("G" & lngRow - 1) <> strKey Then
            Rows(lngRow).Insert
            strKey = wsSrc.Range("F" & lngRow - 1) & wsSrc.Range("G" & lngRow - 1)
        End If
    Next lngRow
   
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[Ganeshan]

Hi Ganeshan,

Welcome to MrExcel!!

Try this:

Option Explicit
Sub Macro1()

    Dim wsSrc As Worksheet
    Dim lngLastRow, lngRow As Long
    Dim strKey As String
  
    Application.ScreenUpdating = False
  
    Set wsSrc = ThisWorkbook.Sheets("Sheet1") '<- Sheet name containing the data. Change to suit if necessary.
    lngLastRow = wsSrc.Range("F:G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  
    For lngRow = lngLastRow To 3 Step -1
        If Len(strKey) = 0 Then
            strKey = wsSrc.Range("F" & lngRow) & wsSrc.Range("G" & lngRow)
        End If
        If wsSrc.Range("F" & lngRow - 1) & wsSrc.Range("G" & lngRow - 1) <> strKey Then
            Rows(lngRow).Insert
            strKey = wsSrc.Range("F" & lngRow - 1) & wsSrc.Range("G" & lngRow - 1)
        End If
    Next lngRow
  
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

Hi @robert,

The code works great and thanks.
I have a question, the loop runs even for the header and creates a row space between the header which is Row 2. How do I stop the loop and make it run only for the data and not the header Row?

 

[Trebor76]

The code works great and thanks.

You're welcome

I have a question, the loop runs even for the header and creates a row space between the header which is Row 2. How do I stop the loop and make it run only for the data and not the header Row?

Try this:

Option Explicit
Sub Macro1()

    Dim wsSrc As Worksheet
    Dim lngLastRow, lngRow As Long
    Dim strKey As String
   
    Application.ScreenUpdating = False
   
    Set wsSrc = ThisWorkbook.Sheets("Sheet1") '<- Sheet name containing the data. Change to suit if necessary.
    lngLastRow = wsSrc.Range("F:G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   
    For lngRow = lngLastRow To 2 Step -1
        If lngRow > 2 Then
            If Len(strKey) = 0 Then
                strKey = wsSrc.Range("F" & lngRow) & wsSrc.Range("G" & lngRow)
            End If
            If wsSrc.Range("F" & lngRow - 1) & wsSrc.Range("G" & lngRow - 1) <> strKey Then
                Rows(lngRow).Insert
                strKey = wsSrc.Range("F" & lngRow - 1) & wsSrc.Range("G" & lngRow - 1)
            End If
        End If
    Next lngRow
   
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[Ganeshan]

Thank you it works great.

 

[Trebor76]

Thanks for letting us know and you're welcome

 

[tjdickinson]

You're welcome



Try this:

Option Explicit
Sub Macro1()

    Dim wsSrc As Worksheet
    Dim lngLastRow, lngRow As Long
    Dim strKey As String
  
    Application.ScreenUpdating = False
  
    Set wsSrc = ThisWorkbook.Sheets("Sheet1") '<- Sheet name containing the data. Change to suit if necessary.
    lngLastRow = wsSrc.Range("F:G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  
    For lngRow = lngLastRow To 2 Step -1
        If lngRow > 2 Then
            If Len(strKey) = 0 Then
                strKey = wsSrc.Range("F" & lngRow) & wsSrc.Range("G" & lngRow)
            End If
            If wsSrc.Range("F" & lngRow - 1) & wsSrc.Range("G" & lngRow - 1) <> strKey Then
                Rows(lngRow).Insert
                strKey = wsSrc.Range("F" & lngRow - 1) & wsSrc.Range("G" & lngRow - 1)
            End If
        End If
    Next lngRow
  
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

I have, I think, a similar question, but I'm struggling to adapt the code for my context. This code will go in a much longer macro which will execute a number of formatting operations on each sheet in the workbook.

(Note: the non-ideal starting conditions are the result of exporting from an application, which cannot be avoided.)

Column A has a list of time ranges on two lines indicating the start and end time for each row. I can make Column G a 'control' column:

        Dim timeFill() As Variant
        timeFill = VBA.Array("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")
        timeFill = Application.WorksheetFunction.Transpose(timeFill)
        Range("G3:G15").NumberFormat = "@"
        Range("G3:G15").Value = timeFill

Starting in A4 (because all the tables will start at the same time), it compares the first line in A4 to G4. If the values are the same, then it moves on. If the values are not the same*, then it inserts a new row from A4:F4, shifting the other cells down (so that the control column doesn't change). This repeats through row 15. Then it deletes column G.

* The exception is at the bottom of the table: if Ax is blank but Gx is not blank, then a row should be inserted from Ax:Fx. When Ax is blank AND Gx is also blank, it has reached the bottom of the table.

I can't figure out how to (a) compare only part of the value of A and (b) insert the row within the limits so that the cells shift down and G is not modified. Any help would be greatly appreciated!

 

[Trebor76]

Hi tjdickinson,

It's probably best to start a new thread with a link back to this one if you think it help someone provide a solution for you.

It sounds like you need to create a range variable so as the code goes along it adds the row(s) to it if applicable and if after all the rows have been checked and the variable is not empty (nothing) insert the rows from it then. You also say that Col. G is a helper column but it starts at Row 3 where the data starts at Row 4 and if the data in Col. A is actually a time Excel may have trouble comparing Col. A to Col. G as the later is text.

Regards,

Robert

 

[tjdickinson]

Hi tjdickinson,

It's probably best to start a new thread with a link back to this one if you think it help someone provide a solution for you.

It sounds like you need to create a range variable so as the code goes along it adds the row(s) to it if applicable and if after all the rows have been checked and the variable is not empty (nothing) insert the rows from it then. You also say that Col. G is a helper column but it starts at Row 3 where the data starts at Row 4 and if the data in Col. A is actually a time Excel may have trouble comparing Col. A to Col. G as the later is text.

Regards,

Robert

Hi, Robert, thanks for your reply!

I managed to figure out something that works, even if it isn't quite optimal or the most efficient:

        If ActiveSheet.Name <> "Toezicht" Then
            Dim timeFill() As Variant
            timeFill = VBA.Array("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")
            timeFill = Application.WorksheetFunction.Transpose(timeFill)
            Range("G3:G15").NumberFormat = "@"
            Range("G3:G15").Value = timeFill
    
            For i = 4 To 15
                StopPosition = InStr(1, Cells(i, 1), Chr(10)) - 1
                TimeG = Cells(i, 7)
                
                If Len(Cells(i, 1)) > 0 Then
                    TimeA = Left(Cells(i, 1), StopPosition)
                    Else:  TimeA = ""
                End If
                
                If TimeA <> TimeG Then
                    Cells(i, 1).Resize(1, 6).Insert shift:=xlDown
                End If
            Next i
            Columns("G:G").Delete shift:=xlLeft
        End If

(The IF at the start of the code is because I need the code to run on three different kinds of timetables, one of which has a different layout, so this prevents the code from running on that timetable.)

Because the times in colA were not typed into Excel, they aren't registered in a time format, so the comparison works fine.

I think the problem with optimisation is that it is populating cells which will eventually be deleted, and then it has to go row by row, 12 times, checking each row. On the one hand, it kind of has to do that because, well, that's what needs to happen, but I just wonder if there's a faster way.

An idea that's just popped into my head (but I don't really know how to execute it, if it's even possible) is something like making an array of the values in colA, comparing that to the timeFill array, and using those results to insert the extra rows. Maybe something like comparing the indices, if they don't match, insert "" into the colA array, and then using the index value of "" elements in the colA array to insert the rows in one fell swoop.

What do you think?

 

[Trebor76]

Try this where rows are only shifted down at the end of the process (if there are any) and no helper column is used:

Option Explicit
Sub Macro1()

    Dim TimeArray As Variant
    Dim i As Long
    Dim TimeCheck As String
    Dim rng As Range
    
    Application.ScreenUpdating = False
    
    TimeArray = Array("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")
    
    For i = 4 To 15
        If Len(Cells(i, "A")) > 0 And InStr(Cells(i, "A"), Chr(10)) > 0 Then
            TimeCheck = Split(Cells(i, "A"), Chr(10))(0)
            If IsNumeric(Application.Match(TimeCheck, TimeArray, 0)) = False Then
                If rng Is Nothing Then
                    Set rng = Cells(i, "A")
                Else
                    Set rng = Union(rng, Cells(i, "A"))
                End If
            End If
        End If
    Next i
    
    If Not rng Is Nothing Then
        rng.EntireRow.Delete Shift:=xlDown
    End If
    
    Application.ScreenUpdating = False

End Sub