If cell contains text, then insert formula above VBA

[Cassie_H]

Hello all,

I think this is my second time posting...maybe first!

I have a spreadsheet that has information in it that will change, the columns will get greater and fewer in number as it comes from an Access Database. The number of rows will remain, always ending at 1202.

Anyway, what I'm trying to figure out is how to get VBA to insert a formula above any cell that has the text "QAAQ" in it.

1

A

B

C

D

E

F

G

H

I

J

K

L

2

3

REF

NUM

NAME

QAAQ01a

QAAQ01b

QAAQ02

QAAQ02a

Memo 01

Memo 02

Q Error

PA Error

4

125

544

J Bloggs

1

2

1

1

2

2

abc

abc

What I think I need is a loop that tests to see if the cell on Row 2 contains "QAAQ*" and if true, inserts "=COUNTIF(from row 3 to row 1202?,2)" in row 1 above the cell.
Does that make sense? I know "from row 3 to row 1202" is not right. but hope I'm making sense?

this is what I have so far:

Sub InsertFormulas2()

Dim wbOpen As Workbook
Dim r As Range
Dim lastcol As Integer
    
    Set wbOpen = Workbooks.Open("C:\NAT\BUS\PAY\PAMPD\" & Range("ProjectTitle") & "\Extraction Data\Latest Extraction Data.xlsx")
    
    Worksheets("qryCompletedCases").Activate
    ActiveSheet.UsedRange.Copy
    Workbooks("Latest Extraction Data.xlsx").Close
    
    Worksheets("Completed").Activate
    ActiveSheet.Paste Destination:=Worksheets("Completed").Range("A2")

    Set r = ActiveSheet.Range("2:2").Find(what:="QAAQ", Lookat:=xlPart)
    'If Not r Is Nothing Then r.Offset(1).Formula = uhhhhhh
    
    With ActiveSheet
    lastcol = .Cells(.Columns.Count, "A").End(xlToRight).Column
    End With


End Sub

Thank you in advance! Please let me know if I need to be clearer, or if any further information is required!

 

[JackDanIce]

Try:

Sub InsertFormulas2_v1()

    Dim wbk         As Workbook
    Dim rng         As Range
    Dim LC          As Long
    
    Dim frm         As String
    Dim colLetter   As String
    
    frm = "=COUNTIF(@1$3:@1$1202,2)"
    
    Set wkb = Workbooks.Open("C:\NAT\BUS\PAY\PAMPD\" & Range("ProjectTitle").value & "\Extraction Data\Latest Extraction Data.xlsx")

    With wkb
        .Sheets("qryCompletedCases").UsedRange.Copy
        .Close False
    End With
    Set wkb = Nothing
    
    With Sheets("Completed")
        .Range("A2").PasteSpecial xlPasteValues
        LC = .Cells(2, .Columns.Count).End(xlToLeft).Column
        
        On Error Resume Next
        Set rng = .Cells(2, 1).Resize(, LC).Find(what:="QAAQ*", lookat:=xlPart)
        On Error GoTo 0
                
        If Not rng Is Nothing Then
            colLetter = Split(rng.Address(1, 0), "$")(0)
            frm = Replace(frm, "@1", colLetter)
            rng.Offset(-1).Formula = frm
            Set rng = Nothing
        End If
        If .Name <> ActiveSheet.Name Then .Select
    End With
        
End Sub

 

[Cassie_H]

Thank you for writing all that, JackDanIce! I very much appreciate it. And it's almost working! I made a few changes, for some reason it didn't like it ".value" after my "ProjectTitle" range and I changed the type of paste. I think because the other workbook is closed, it didn't like that sort of paste?

But perhaps because of that change, it now won't loop through? It's working brilliantly in the fact that it's putting the CountIf (thank you for figuring that out for me, would have taken me hours!) in the first column that the "QAAQ" appears but then it stops. Any idea why?

Sub InsertFormulas2_v1()

    Dim wbk As Workbook
    Dim rng As Range
    Dim LC As Long
    
    Dim frm As String
    Dim colLetter As String
    
    frm = "=COUNTIF(@1$3:@1$1202,2)"
    
    Set wbk = Workbooks.Open("C:\NAT\BUS\PAY\PAMPD\" & Range("ProjectTitle") & "\Extraction Data\Latest Extraction Data.xlsx")

    With wbk
        .Sheets("qryCompletedCases").UsedRange.Copy
        .Close False
    End With
    Set wbk = Nothing
    
    With Sheets("Completed")
        .Paste Destination:=Worksheets("Completed").Range("A2")
        LC = .Cells(2, .Columns.Count).End(xlToLeft).Column
        
        On Error Resume Next
        Set rng = .Cells(2, 1).Resize(, LC).Find(what:="QAAQ*", lookat:=xlPart)
        On Error GoTo 0
                
        If Not rng Is Nothing Then
            colLetter = Split(rng.Address(1, 0), "$")(0)
            frm = Replace(frm, "@1", colLetter)
            rng.Offset(-1).Formula = frm
            Set rng = Nothing
        End If
        If .Name <> ActiveSheet.Name Then .Select
    End With
        
End Sub

 

[Cassie_H]

Okay, I've been working on this pretty much all day (which should give an indication of my skill level...none!) and I've got it loop through, but now I just need help on how to get the code to move to the next column.

Sub InsertFormulas2_v2()

    Dim wbk As Workbook
    Dim rng As Range
    Dim LC As Long
    Dim i As Long
    
    Dim frm As String
    Dim colLetter As String
    
    frm = "=COUNTIF(@1$3:@1$1202,2)"
      
    Set wbk = Workbooks.Open("C:\NAT\BUS\PAY\PAMPD\" & Range("ProjectTitle") & "\Extraction Data\Latest Extraction Data.xlsx")

    With wbk
        .Sheets("qryCompletedCases").UsedRange.Copy
        .Close False
    End With
    Set wbk = Nothing
    
    
    With Sheets("Completed")
        .Paste Destination:=Worksheets("Completed").Range("A2")
        LC = .Cells(2, .Columns.Count).End(xlToLeft).Column
    End With
    
    i = 1
    
    Do Until i > LC
    With Sheets("Completed")
        On Error Resume Next
        Set rng = .Cells(2, 1).Resize(, LC).Find(what:="QAAQ*", lookat:=xlPart)
        On Error GoTo 0
                
        If Not rng Is Nothing Then
            colLetter = Split(rng.Address(1, 0), "$")(0)
            frm = Replace(frm, "@1", colLetter)
            rng.Offset(-1).Formula = frm
            i = i + 1
        End If
        If .Name <> ActiveSheet.Name Then .Select
    End With
      Loop
      
Set rng = Nothing
 
End Sub

 

[JackDanIce]

Try:

Sub InsertFormulas2_v3()

    Dim wbk     As Workbook
    Dim rng     As Range
    Dim LC      As Long
    Dim i       As Long
    
    Dim frm     As String
    Dim colLetter As String
    
    Const findTerm As String = "QAAQ*"
    
    frm = "=COUNTIF(@1$3:@1$1202,2)"
      
    Set wbk = Workbooks.Open("C:\NAT\BUS\PAY\PAMPD\" & Range("ProjectTitle") & "\Extraction Data\Latest Extraction Data.xlsx")

    With wbk
        .Sheets("qryCompletedCases").UsedRange.Copy
        .Close False
    End With
    Set wbk = Nothing
    
    
    With Sheets("Completed")
    
        If .Name <> ActiveSheet.Name Then .Select
        .Range("A2").Paste
        Application.ScreenUpdating = False
        
        LC = .Cells(2, .Columns.Count).End(xlToLeft).Column
        
        For i = 1 To LC
        
            On Error Resume Next
            Set rng = .Cells(2, i).Resize(, LC - i + 1).Find(What:=findTerm, lookat:=xlPart)
            On Error GoTo 0
            
            If Not rng Is Nothing Then
                colLetter = Split(rng.Address(1, 0), "$")(0)
                frm = Replace(frm, "@1", colLetter)
                rng.Offset(-1).Formula = frm
                i = i + 1
                
            Else
                If MsgBox("Value not fonud in column: " & colLetter & " continue?", vbYesNo) = vbNo Then
                    Exit Sub
                End If
            End If
            
            Set rng = Nothing
            
        Next i
        
    End With
           
    Application.ScreenUpdating = True
           
End Sub

 

[Cassie_H]

Thank you again for replying and there is some improvement in this one! The macro is now moving along the top row, but it is only inserting the formula every second column. Also, the formula is not updating according to which column it is in. The 'frm' variable is set when it finds the first column that 'QAAQ' is in, for example D and then the formula it inserts is " =Countif(D3:D1202,2)" no matter which column it is in.

Once again, thank you for your time!

 

[JackDanIce]

This should solve the formula problem but on my test copy, the code is moving along each sequential column and not every 2nd column, I'm not sure why it's doing that on yours, however, try:

Sub InsertFormulas2_v4()


    Dim wbk     As Workbook
    Dim rng     As Range
    Dim LR      As Long
    Dim LC      As Long
    Dim i       As Long
    
    Dim frm     As String
    Dim stemp   As String
    Dim colLetter As String
    
    Const findTerm As String = "QAAQ*"
    
    frm = "=COUNTIF(@1$3:@1$1202,2)"
      
    Set wbk = Workbooks.Open("C:\NAT\BUS\PAY\PAMPD\" & Range("ProjectTitle") & "\Extraction Data\Latest Extraction Data.xlsx")


    With wbk
        .Sheets("qryCompletedCases").UsedRange.Copy
        .Close False
    End With
    Set wbk = Nothing
    
    
    With Sheets("Completed")
    
        If .Name <> ActiveSheet.Name Then .Select
        .Range("A2").Paste
        Application.ScreenUpdating = False
        
        LC = .Cells(2, .Columns.Count).End(xlToLeft).Column
        
        
        For i = 1 To LC
                        
            
            On Error Resume Next
            Set rng = .Cells(3, i).Resize(1201).Find(What:=findTerm, lookat:=xlPart)
            On Error GoTo 0
            
            If Not rng Is Nothing Then
                colLetter = Split(rng.Address(1, 0), "$")(0)
                stemp = Replace(frm, "@1", colLetter)
                rng.Offset(-1).Formula = stemp
                i = i + 1
                stemp = vbNullString
            Else
                If MsgBox("Value not fonud in column: " & colLetter & " continue?", vbYesNo) = vbNo Then
                    Exit Sub
                End If
            End If
            
            Set rng = Nothing
            
        Next i
        
    End With
           
    Application.ScreenUpdating = True
           
End Sub

 

[Cassie_H]

Hi again, thank you for those amendments. I don't know why but it still wouldn't work! I ended up scraping the whole thing and starting again.

This is what I came up with and it works!

Sub Insert_Formula()
    
    Dim rng             As Range
    Dim aCell           As Range
    Dim bCell           As Range
    
    Dim ws              As Worksheet
    Dim wbk             As Workbook
    
    Dim SearchString    As String
    Dim frm             As String
    Dim sTemp           As String
    Dim colLetter       As String
    
     
    On Error GoTo 0
     
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
     
        Set ws = Worksheets("Completed")
        Set rng = ws.Rows(2)
        Set wbk = Workbooks.Open("C:\NAT\BUS\PAY\PAMPD\" & Range("ProjectTitle") & "\Extraction Data\Latest Extraction Data.xlsx")
frm = "=COUNTIF(@1$3:@1$1202,2)"
        SearchString = "QAAQ*"

    With wbk
        .Sheets("qryCompletedCases").UsedRange.Copy
        .Close False
    End With
    
        Set wbk = Nothing
    
    With ws
        If .Name <> ActiveSheet.Name Then .Select
        .Paste Destination:=ws.Range("A2")
        End With
     
    Set aCell = rng.Find(What:=SearchString, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
                colLetter = Split(aCell.Address(1, 0), "$")(0)
                sTemp = Replace(frm, "@1", colLetter)
                aCell.Offset(-1).Formula = sTemp
    
    If Not aCell Is Nothing Then
        Set bCell = aCell
        Do
            Set aCell = rng.FindNext(After:=aCell)
                colLetter = Split(aCell.Address(1, 0), "$")(0)
                sTemp = Replace(frm, "@1", colLetter)
                aCell.Offset(-1).Formula = sTemp
            If Not aCell Is Nothing Then
                If aCell.Address = bCell.Address Then Exit Do
            Else
                Exit Do
            End If

        Loop
    Else
        Exit Sub
    End If
     
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
     
End Sub

I have no idea why the stuff you wrote for me did not work but I really appreciate your time. Thank you for returning so often to assist!

 

[JackDanIce]

Glad you found a solution in the end.