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

N

nikshah22

New Member
Joined
Jul 11, 2022
Messages
8
Office Version
  1. 2019
Platform
  1. Windows
  2. MacOS
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​
EarthEarthXYZ
10​
20​
30​
TRUE​
ABC
11​
2022​
2nd Quarter
5​
May
12​
EarthEarthLMN
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:

  1. 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.

  2. 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)

  3. 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)

  4. New cells from O:Q will have the number 0. (in red in the table below)

  5. 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​
EarthEarthXYZ
10​
20​
30​
TRUE​
ABC
11​
2022​
2nd Quarter
5​
May
11​
EarthEarthABC
0​
0​
0​
TRUE​
LMN
12​
2022​
2nd Quarter
5​
May
12​
EarthEarthLMN
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 :)
 

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
Sort by date Sort by votes
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 ?
 
Upvote 0
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
 
Upvote 0
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 ?
Click to expand...
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!
 
Upvote 0
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!
Click to expand...

You are also welcome to suggest how to make this code more efficient. I know I haven't used variables at all lol.
 
Upvote 0
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
 
Upvote 0
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
Click to expand...
Thank you so much! Will try this out.
 
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Question Question
VBA Attempting to Insert New Rows but Only needing Column A copied
2 3 4
Replies
30
Views
1K
jolivanes
jolivanes
G
  • Solved
Skip Row When Column Word Meet
2
Replies
14
Views
358
Peter_SSs
Peter_SSs
Kellie220
  • Question Question
VBA to Collapse Rows (3 part question)
Replies
1
Views
272
Artik
Artik
R
  • Question Question
[VBA] - Need to Hide one column and need sum of columns
Replies
0
Views
192
rsolanki
R
O
  • Question Question
Creating workbooks for a team of staff
Replies
1
Views
200
HighAndWilder
H

Forum statistics

Threads
1,223,893
Messages
6,175,239
Members
452,621
Latest member
Laura_PinksBTHFT

Share this page

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