If cell contains text, then insert formula above VBA

C

Cassie_H

New Member
Joined
Dec 29, 2011
Messages
9
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.

[table="width: 500, class: grid, align: center"]
[tr]
[td]1[/td]
[td]A[/td]
[td]B[/td]
[td]C[/td]
[td]D[/td]
[td]E[/td]
[td]F[/td]
[td]G[/td]
[td]H[/td]
[td]I[/td]
[td]J[/td]
[td]K[/td]
[td]L[/td]
[/tr]
[tr]

[td]2[/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[/tr]
[tr]

[td]3[/td]
[td]REF[/td]
[td]NUM[/td]
[td]NAME[/td]
[td]QAAQ01a[/td]
[td]QAAQ01b[/td]
[td]QAAQ02[/td]
[td]QAAQ02a[/td]
[td]Memo 01[/td]
[td]Memo 02[/td]
[td][/td]
[td]Q Error[/td]
[td]PA Error[/td]
[/tr]
[tr]

[td]4[/td]
[td]125[/td]
[td]544[/td]
[td]J Bloggs[/td]
[td]1[/td]
[td]2[/td]
[td]1[/td]
[td]1[/td]
[td]2[/td]
[td]2[/td]
[td][/td]
[td]abc[/td]
[td]abc[/td]
[/tr]
[/table]

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. :confused: but hope I'm making sense?

this is what I have so far:

Code: 
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!
 

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
Sort by date Sort by votes
Try:
Code: 
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
 
Upvote 0
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?

Code: 
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
 
Upvote 0
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.

Code: 
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
 
Upvote 0
Try:
Code: 
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
 
Upvote 0
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!
 
Upvote 0
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:
Code: 
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
 
Upvote 0
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!

Code: 
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!
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Question Question
VBA to insert new row if cell contains certain symbol
Replies
1
Views
243
Sequoyah
Sequoyah
J
  • Question Question
vba to find specific text in a column and then when found copy all the rows above it
Replies
1
Views
75
mumps
mumps
S
  • Question Question
VBA Copy/Paste from different workbooks
Replies
1
Views
354
NdNoviceHlp
NdNoviceHlp
O
  • Question Question
User-defined type not defined - vba/excel error
Replies
4
Views
144
RoryA
RoryA
M
  • Question Question
Please help me to correct Excel VBA code!
Replies
1
Views
310
Minh Tuan VN
M

Forum statistics

Threads
1,223,270
Messages
6,171,102
Members
452,379
Latest member
IainTru

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