VBA - Identify "FALSE" value in column and insert cells in certain columns above it

nikshah22 · Jul 11, 2022

Hello,

I'm new to Excel VBA and have run into a complex problem for my current level. Let me explain:

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

XYZ

10

2022

2nd Quarter

5

May

10

Earth

XYZ

10

20

30

TRUE

ABC

11

2022

2nd Quarter

5

May

12

Earth

LMN

6

34

5

FALSE

LMN

12

2022

2nd Quarter

5

May

13

PQR

45

8

12

FALSE

PQR

13

The formula in column S is =(A2&B2)=(N2&K2) and fills down to the second last row i.e. =(A4&B4)=(N4&K4). In the original worksheet, there are over 5000 rows of such data that include the same formula in column S. I want to write code that will do the following:

Run through column S from top to bottom and identify the first FALSE value. Then add new cells from columns G to S in the row above it.
For example, in this case, code will identify FALSE in row 3 and add new cells G3: S3, pushing the existing data down to G4:S4.
Copy the values in new cells G:J and L:M from the cells in the corresponding column and the row above. That is, the values in the new G3:J3 and L3:M3 will be copied from G2:J2 and L2:M2. (in blue in the table below)
Values in new cells in K and N copied from B and A in the same row, i.e., K3 and N3 will copy from B3 and A3. (in green in the table below)
New cells from O:Q will have the number 0. (in red in the table below)
Finally, the column S formula will be filled down to the last row and this entire code will loop until there are no more FALSE values in column S.

Here is what the data looks like after all the macro(s) is/are run:

XYZ	10	2022	2nd Quarter	5	May	10	Earth	Earth	XYZ	10	20	30	TRUE
ABC	11	2022	2nd Quarter	5	May	11	Earth	Earth	ABC	0	0	0	TRUE
LMN	12	2022	2nd Quarter	5	May	12	Earth	Earth	LMN	6	34	5	TRUE
PQR	13	2022	2nd Quarter	5	May	13			PQR	45	8	12	TRUE

The code I am using as a basis for my macro is below. I found it here on the forum but haven't been able to tweak it to my needs:

VBA Code:

Sub InsertOnFalse()

Dim n As Long
Dim ws As Worksheet

Set ws = ActiveWorkbook.Sheets("Audit Volume")

Application.ScreenUpdating = False

n = 1625
Do While Not ws.Range("A" & n) = ""
    If ws.Range("S" & n) = False Then
        ws.Range("R" & n, "S" & n).Insert Shift:=xlShiftDown
        ws.Range("S" & n).Offset(-1, 0).Copy
        ws.Range("S" & n).PasteSpecial (xlPasteFormulas)
    End If
    ws.Range("S" & n).Copy
    ws.Range("S" & n).Offset(1, 0).PasteSpecial (xlPasteFormulas)
    n = n + 1
Loop

End Sub

I've spent a lot of time trying to learn more VBA off the internet and to think of different ways to do this but to no avail. Your help and input will therefore be greatly appreciated

Alex Blakenburg · Jul 12, 2022

Are you just trying to solve a problem or trying to learn VBA ?
The way it looks to me you effectively have 2 tables which can be joined on Table1-col A to Table2-col N and Table1-col B to Table2-col K
If the ID no is unique then you probably only even need B to K.

So you do have options:

Lookup formula
Power Query - should be really easy but might be an issue for your MacOS
VBA
- keep going the way you are and modify your code
- or much faster would be using a dictionary but that would only work on windows and not the MacOS
- It may be possible to use a collection to mimic a dictionary and would work on both platforms (no promises though )
- Using arrays much faster than your method but not as good as a dictionary.

Let us know which way you want to go on it and does it need to run on a MacOs and is my assumption that the A&B combination is unique in columns A&B ?

bebo021999 · Jul 12, 2022

What I could see is you are trying to line A&B of left table and N&K of the right one, if they both match together
Raising question:
This sample suppose they are in 1-row distance. What if, LMN-12 in row 3 of table 2, but LMN-12 in table 1, in, i.e, row 10 (not row 4) ?
Why not trying approach in other way:
1) Read table 2 into an array
2) base on table 1, write array back to the sheet, matching row - by -row

nikshah22 · Jul 12, 2022

Alex Blakenburg said:
Are you just trying to solve a problem or trying to learn VBA ?
The way it looks to me you effectively have 2 tables which can be joined on Table1-col A to Table2-col N and Table1-col B to Table2-col K
If the ID no is unique then you probably only even need B to K.

So you do have options:

Lookup formula

Power Query - should be really easy but might be an issue for your MacOS

VBA

keep going the way you are and modify your code

or much faster would be using a dictionary but that would only work on windows and not the MacOS

It may be possible to use a collection to mimic a dictionary and would work on both platforms (no promises though )

Using arrays much faster than your method but not as good as a dictionary.

Let us know which way you want to go on it and does it need to run on a MacOs and is my assumption that the A&B combination is unique in columns A&B ?

Hi, thanks for your reply and your suggestions! I've managed to write code that does steps 1 to 4 perfectly. It also does that part of step 5 which involves the formula.

The only thing I need now is code for the loop.

VBA Code:

Sub Cells_Insert()

Set ws = ActiveWorkbook.Sheets("Audit Volume")

'Do Until 
    
        Range("S1700").EntireColumn.Select
        Selection.Find(What:="FALSE", LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=True, SearchFormat:=False).Activate
    
        ActiveCell.EntireRow.Insert
        lr = ActiveCell.Row
        Range("A" & lr, "F" & lr).Delete Shift:=xlUp
        Range("S" & lr).Delete Shift:=xlUp
        
    ThisWorkbook.Sheets("Audit Volume").Range("G" & lr - 1, "J" & lr - 1).Copy ThisWorkbook.Sheets("Audit Volume").Range("G" & lr, "J" & lr)
    ThisWorkbook.Sheets("Audit Volume").Range("L" & lr - 1, "M" & lr - 1).Copy ThisWorkbook.Sheets("Audit Volume").Range("L" & lr, "M" & lr)
    ThisWorkbook.Sheets("Audit Volume").Range("B" & lr).Copy ThisWorkbook.Sheets("Audit Volume").Range("K" & lr)
    ThisWorkbook.Sheets("Audit Volume").Range("A" & lr).Copy ThisWorkbook.Sheets("Audit Volume").Range("N" & lr)
    ThisWorkbook.Sheets("Audit Volume").Range("O5041").Copy ThisWorkbook.Sheets("Audit Volume").Range("O" & lr, "Q" & lr)

    fr = Worksheets("Audit Volume").Cells.Find("*", Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False).Row
    Range("S5100").Formula = "=(A5100&B5100)=(N5100&K5100)"
    Range("S5100").AutoFill Range("S5100:S" & fr)

'Loop

End Sub

I want the code between the comments to loop until all the values in column S are TRUE and no FALSE values remain. Can you help with this? I am doing everything on a Windows PC.

Again, thanks a ton!

nikshah22 · Jul 12, 2022

nikshah22 said:

Hi, thanks for your reply and your suggestions! I've managed to write code that does steps 1 to 4 perfectly. It also does that part of step 5 which involves the formula.

The only thing I need now is code for the loop.

VBA Code:

Sub Cells_Insert()

Set ws = ActiveWorkbook.Sheets("Audit Volume")

'Do Until
   
        Range("S1700").EntireColumn.Select
        Selection.Find(What:="FALSE", LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=True, SearchFormat:=False).Activate
   
        ActiveCell.EntireRow.Insert
        lr = ActiveCell.Row
        Range("A" & lr, "F" & lr).Delete Shift:=xlUp
        Range("S" & lr).Delete Shift:=xlUp
       
    ThisWorkbook.Sheets("Audit Volume").Range("G" & lr - 1, "J" & lr - 1).Copy ThisWorkbook.Sheets("Audit Volume").Range("G" & lr, "J" & lr)
    ThisWorkbook.Sheets("Audit Volume").Range("L" & lr - 1, "M" & lr - 1).Copy ThisWorkbook.Sheets("Audit Volume").Range("L" & lr, "M" & lr)
    ThisWorkbook.Sheets("Audit Volume").Range("B" & lr).Copy ThisWorkbook.Sheets("Audit Volume").Range("K" & lr)
    ThisWorkbook.Sheets("Audit Volume").Range("A" & lr).Copy ThisWorkbook.Sheets("Audit Volume").Range("N" & lr)
    ThisWorkbook.Sheets("Audit Volume").Range("O5041").Copy ThisWorkbook.Sheets("Audit Volume").Range("O" & lr, "Q" & lr)

    fr = Worksheets("Audit Volume").Cells.Find("*", Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False).Row
    Range("S5100").Formula = "=(A5100&B5100)=(N5100&K5100)"
    Range("S5100").AutoFill Range("S5100:S" & fr)

'Loop

End Sub

I want the code between the comments to loop until all the values in column S are TRUE and no FALSE values remain. Can you help with this? I am doing everything on a Windows PC.

Again, thanks a ton!

You are also welcome to suggest how to make this code more efficient. I know I haven't used variables at all lol.

Alex Blakenburg · Jul 13, 2022

I might have totally misunderstood the data but give the below a try on a copy of your workbook.

It does assume the Name & ID combination is unique. If that is not the case it is a show stopper so let me know.
It also sets the firstRow to be 2, change that is not the case.

VBA Code:

Sub LookupToAlignData()

    Dim shtAudit As Worksheet
    Dim rngMain As Range, rngDetails As Range
    Dim arrMain As Variant, arrDetails As Variant, arrOutDet() As Variant
    Dim lrMain As Long, lrDetails As Long, firstRow As Long
    Dim dictDet As Object
    Dim sName As String, sID As String, dictKey As String
    Dim i As Long, j As Long
    
    Set shtAudit = Worksheets("Audit Volume")
    firstRow = 2                                    ' <--- Change to first data row if different
    
    With shtAudit
        lrMain = .Cells(Rows.Count, "A").End(xlUp).Row
        Set rngMain = .Range("A" & firstRow & ":B" & lrMain)
        arrMain = rngMain.Value
        
        lrDetails = .Cells(Rows.Count, "N").End(xlUp).Row   ' <-- Confirm this is a good column to use
        Set rngDetails = .Range("G" & firstRow & ":S" & lrDetails)
        arrDetails = rngDetails.Value
    End With
    
    ' Load details range into Dictionary
    Set dictDet = CreateObject("Scripting.dictionary")
    
    For i = 1 To UBound(arrDetails)
        sName = arrDetails(i, 8)
        sID = arrDetails(i, 5)
        dictKey = sName & "|" & sID
        If Not dictDet.exists(dictKey) Then
            dictDet(dictKey) = i
        End If
    Next i
    
    'ReDim Preserve arrMain(1 To UBound(arrMain, 1), 1 To 19)
    ReDim arrOutDet(1 To UBound(arrMain, 1), 1 To UBound(arrDetails, 2))

    For i = 1 To UBound(arrMain)
        sName = arrMain(i, 1)
        sID = arrMain(i, 2)
        dictKey = sName & "|" & sID
        If dictDet.exists(dictKey) Then
            For j = 1 To UBound(arrDetails, 2)
                arrOutDet(i, j) = arrDetails(dictDet(dictKey), j)
            Next j
        Else
            For j = 1 To UBound(arrDetails, 2)
                Select Case j
                    Case 8
                        arrOutDet(i, j) = sName
                    Case 5
                        arrOutDet(i, j) = sID
                    Case 9 To 11            ' Value columns
                        arrOutDet(i, j) = 0
                    Case Else
                        ' Bring down previous row values
                        If i <> 1 Then
                            arrOutDet(i, j) = arrOutDet(i - 1, j)
                        End If
                End Select
            Next j
        End If
    Next i
    
    Set rngDetails = rngDetails.Resize(UBound(arrMain, 1))
    rngDetails.Value = arrOutDet
    
    With shtAudit
        rngDetails.Columns(UBound(arrOutDet, 2)).Formula = "= A2 & B2 = N2 & K2"
    End With

End Sub

nikshah22 · Jul 13, 2022

Alex Blakenburg said:

I might have totally misunderstood the data but give the below a try on a copy of your workbook.

It does assume the Name & ID combination is unique. If that is not the case it is a show stopper so let me know.
It also sets the firstRow to be 2, change that is not the case.

VBA Code:

Sub LookupToAlignData()

    Dim shtAudit As Worksheet
    Dim rngMain As Range, rngDetails As Range
    Dim arrMain As Variant, arrDetails As Variant, arrOutDet() As Variant
    Dim lrMain As Long, lrDetails As Long, firstRow As Long
    Dim dictDet As Object
    Dim sName As String, sID As String, dictKey As String
    Dim i As Long, j As Long
   
    Set shtAudit = Worksheets("Audit Volume")
    firstRow = 2                                    ' <--- Change to first data row if different
   
    With shtAudit
        lrMain = .Cells(Rows.Count, "A").End(xlUp).Row
        Set rngMain = .Range("A" & firstRow & ":B" & lrMain)
        arrMain = rngMain.Value
       
        lrDetails = .Cells(Rows.Count, "N").End(xlUp).Row   ' <-- Confirm this is a good column to use
        Set rngDetails = .Range("G" & firstRow & ":S" & lrDetails)
        arrDetails = rngDetails.Value
    End With
   
    ' Load details range into Dictionary
    Set dictDet = CreateObject("Scripting.dictionary")
   
    For i = 1 To UBound(arrDetails)
        sName = arrDetails(i, 8)
        sID = arrDetails(i, 5)
        dictKey = sName & "|" & sID
        If Not dictDet.exists(dictKey) Then
            dictDet(dictKey) = i
        End If
    Next i
   
    'ReDim Preserve arrMain(1 To UBound(arrMain, 1), 1 To 19)
    ReDim arrOutDet(1 To UBound(arrMain, 1), 1 To UBound(arrDetails, 2))

    For i = 1 To UBound(arrMain)
        sName = arrMain(i, 1)
        sID = arrMain(i, 2)
        dictKey = sName & "|" & sID
        If dictDet.exists(dictKey) Then
            For j = 1 To UBound(arrDetails, 2)
                arrOutDet(i, j) = arrDetails(dictDet(dictKey), j)
            Next j
        Else
            For j = 1 To UBound(arrDetails, 2)
                Select Case j
                    Case 8
                        arrOutDet(i, j) = sName
                    Case 5
                        arrOutDet(i, j) = sID
                    Case 9 To 11            ' Value columns
                        arrOutDet(i, j) = 0
                    Case Else
                        ' Bring down previous row values
                        If i <> 1 Then
                            arrOutDet(i, j) = arrOutDet(i - 1, j)
                        End If
                End Select
            Next j
        End If
    Next i
   
    Set rngDetails = rngDetails.Resize(UBound(arrMain, 1))
    rngDetails.Value = arrOutDet
   
    With shtAudit
        rngDetails.Columns(UBound(arrOutDet, 2)).Formula = "= A2 & B2 = N2 & K2"
    End With

End Sub

Thank you so much! Will try this out.

VBA - Identify "FALSE" value in column and insert cells in certain columns above it

nikshah22

New Member

Excel Facts

Alex Blakenburg

MrExcel MVP

bebo021999

Well-known Member

nikshah22

New Member

nikshah22

New Member

Alex Blakenburg

MrExcel MVP

nikshah22

New Member

Similar threads

Forum statistics

Share this page

VBA - Identify "FALSE" value in column and insert cells in certain columns above it

nikshah22

New Member

Excel Facts

Alex Blakenburg

MrExcel MVP

bebo021999

Well-known Member

nikshah22

New Member

nikshah22

New Member

Alex Blakenburg

MrExcel MVP

nikshah22

New Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock