VBA routine - I need to type in a formula into a cell and fill down

[Burrgogi]

Sub Fanatical_Table()
'
    Workbooks.Open Filename:= _
        "D:\Games\Game Collection\Fanatical Bundle Tracker Workbook  (started on Nov 6, 2020).xlsm"
    Sheets.Add After:=Sheets(Sheets.Count), Type:= _
        "D:\Games\Fanatical Bundle Template 2C.xltx"
    ActiveSheet.Name = Format(Date, "mm_dd_yyyy")
    Range("A2").Select
    ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
    ' This deletes the last 2 unnecessary columns
    Columns("J:K").Select
    Selection.Delete Shift:=xlToLeft
    ' Cut the trading cards (TC) column and move it to the left of the Playmode col.
    Columns("I:I").Select
    Selection.Cut
    Columns("G:G").Select
    Selection.Insert Shift:=xlToRight
   ' Look for the word Steam in col. C and replace it with nothing
   Columns("C:C").Select
    Selection.Replace What:="Steam ", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False

   ' cannot figure out how to do the very last part of the routine
End Sub

I've got a very simple VBA routine and I'm stumped on the very last part. I need the routine to look at the values shown in col. B
for example it will say:
Steam 100%
Steam 84%
Steam 95%
Steam 91%
....The number of rows will always vary.

I need just the numerical values only transferred over to col. E. Col. E has already been formatted to display the number as percentage e.g. (92%).

 

[cmowla]

Hi.

Let me know if this does the task as intended:

Sub Fanatical_Table_Modified()

Workbooks.Open Filename:= _
    "D:\Games\Game Collection\Fanatical Bundle Tracker Workbook  (started on Nov 6, 2020).xlsm"
Sheets.Add After:=Sheets(Sheets.Count), Type:= _
    "D:\Games\Fanatical Bundle Template 2C.xltx"
ActiveSheet.Name = Format(Date, "mm_dd_yyyy")
Range("A2").Select
ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False

' This deletes the last 2 unnecessary columns
Columns("J:K").Delete Shift:=xlToLeft

' Cut the trading cards (TC) column and move it to the left of the Playmode col.
Columns("I:I").Cut
Columns("G:G").Insert Shift:=xlToRight

Dim lastRow As Long
lastRow = Cells(ActiveSheet.Rows.Count, "C").End(xlUp).Row

'Look for the word Steam in col. C and replace it with nothing
Range("C3:C" & lastRow).Replace _
    What:="Steam ", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False

lastRow = Cells(ActiveSheet.Rows.Count, "B").End(xlUp).Row
With Range("E3:E" & lastRow)
    .NumberFormat = "General"
    .Formula2 = "=IFERROR(TRIM(SUBSTITUTE(MID(B3,SEARCH(" & Chr(34) & "Steam" & Chr(34) & ",B3,1)+LEN(" & Chr(34) & "Steam" & Chr(34) & "),LEN(B3))," & Chr(34) & "%" & Chr(34) & "," & Chr(34) & "" & Chr(34) & "))," & Chr(34) & Chr(34) & ")"
    .Formula2 = .Value
End With

End Sub

 

[Burrgogi]

Doesn't work.

run-time error 1004:
PasteSpecial method of Worksheet class failed

Doesn't like the following line of code:

    .Formula2 = "=IFERROR(TRIM(SUBSTITUTE(MID(B3,SEARCH(" & Chr(34) & "Steam" & Chr(34) & ",B3,1)+LEN(" & Chr(34) & "Steam" & Chr(34) & "),LEN(B3))," & Chr(34) & "%" & Chr(34) & "," & Chr(34) & "" & Chr(34) & "))," & Chr(34) & Chr(34) & ")"

 

[cmowla]

It seems to me that you're pasting quite a bit of information into the sheet that it's not finished pasting before the changes you wish to make after the paste can be completed.

As an experiment, copy the following sub into your code window:

Sub Pause(secs As Variant)
Dim start, finish
start = Now
finish = DateAdd("s", secs, start)
Do While Now < finish: Loop
End Sub

And put this line of code:

Call Pause(4)

Below the line of code:

ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False

And let me know if that works.

 

[Burrgogi]

It seems to me that you're pasting quite a bit of information into the sheet that it's not finished pasting before the changes you wish to make after the paste can be completed.

I don't think that has anything to do with it. I'm pasting a very modest amount of data into the worksheet.

I noticed in the code you provided originally here:

.Formula2 = "=IFERROR(TRIM(SUBSTITUTE(MID(B3,SEARCH(" & Chr(34) & "Steam" & Chr(34) & ",B3,1)+LEN(" & Chr(34) & "Steam" & Chr(34) & "),LEN(B3))," & Chr(34) & "%" & Chr(34) & "," & Chr(34) & "" & Chr(34) & "))," & Chr(34) & Chr(34) & ")"

You've got it searching for "Steam" when in fact there is no instance of the word at all. Did you notice that I already did a find and replace on that earlier in the subroutine?

 

[cmowla]

You specifically mentioned in the first post that you want to transfer the numerical percentages from column B to column E. In your replacement function, you did column C. So I assumed that two columns had Steam in them.

But if that's the case, then try this:

Sub Fanatical_Table_Modified()

Workbooks.Open Filename:= _
    "D:\Games\Game Collection\Fanatical Bundle Tracker Workbook  (started on Nov 6, 2020).xlsm"
Sheets.Add After:=Sheets(Sheets.Count), Type:= _
    "D:\Games\Fanatical Bundle Template 2C.xltx"
ActiveSheet.Name = Format(Date, "mm_dd_yyyy")
Range("A2").Select
ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False

' This deletes the last 2 unnecessary columns
Columns("J:K").Delete Shift:=xlToLeft

' Cut the trading cards (TC) column and move it to the left of the Playmode col.
Columns("I:I").Cut
Columns("G:G").Insert Shift:=xlToRight

Dim lastRow As Long
lastRow = Cells(ActiveSheet.Rows.Count, "C").End(xlUp).Row

'Look for the word Steam in col. C and replace it with nothing
'Range("C3:C" & lastRow).Replace _
'    What:="Steam ", Replacement:="", LookAt:=xlPart, _
'    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False

lastRow = Cells(ActiveSheet.Rows.Count, "C").End(xlUp).Row
With Range("E3:E" & lastRow)
    .NumberFormat = "General"
    .Formula2 = "=IFERROR(TRIM(SUBSTITUTE(MID(C3,SEARCH(" & Chr(34) & "Steam" & Chr(34) & ",C3,1)+LEN(" & Chr(34) & "Steam" & Chr(34) & "),LEN(C3))," & Chr(34) & "%" & Chr(34) & "," & Chr(34) & Chr(34) & "))," & Chr(34) & Chr(34) & ")"
    .Formula2 = .Value
End With

End Sub

 

[Burrgogi]

You specifically mentioned in the first post that you want to transfer the numerical percentages from column B to column E. In your replacement function, you did column C. So I assumed that two columns had Steam in them.

Sorry, my bad. I meant to say from Col. C to Col E.

 

[Burrgogi]

Sub Fanatical_Table_Modified()

Workbooks.Open Filename:= _
    "D:\Games\Game Collection\Fanatical Bundle Tracker Workbook  (started on Nov 6, 2020).xlsm"
Sheets.Add After:=Sheets(Sheets.Count), Type:= _
    "D:\Games\Fanatical Bundle Template 2C.xltx"
ActiveSheet.Name = Format(Date, "mm_dd_yyyy")
Range("A2").Select
ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False

' This deletes the last 2 unnecessary columns
Columns("J:K").Delete Shift:=xlToLeft

' Cut the trading cards (TC) column and move it to the left of the Playmode col.
Columns("I:I").Cut
Columns("G:G").Insert Shift:=xlToRight

Dim lastRow As Long
lastRow = Cells(ActiveSheet.Rows.Count, "C").End(xlUp).Row

'Look for the word Steam in col. C and replace it with nothing
'Range("C3:C" & lastRow).Replace _
'    What:="Steam ", Replacement:="", LookAt:=xlPart, _
'    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False

lastRow = Cells(ActiveSheet.Rows.Count, "C").End(xlUp).Row
With Range("E3:E" & lastRow)
    .NumberFormat = "General"
    .Formula2 = "=IFERROR(TRIM(SUBSTITUTE(MID(C3,SEARCH(" & Chr(34) & "Steam" & Chr(34) & ",C3,1)+LEN(" & Chr(34) & "Steam" & Chr(34) & "),LEN(C3))," & Chr(34) & "%" & Chr(34) & "," & Chr(34) & Chr(34) & "))," & Chr(34) & Chr(34) & ")"
    .Formula2 = .Value
End With

End Sub

You new code doesn't work. It is still getting caught up on the same line as before:

 .Formula2 = "=IFERROR(TRIM(SUBSTITUTE(MID(C3,SEARCH(" & Chr(34) & "Steam" & Chr(34) & ",C3,1)+LEN(" & Chr(34) & "Steam" & Chr(34) & "),LEN(C3))," & Chr(34) & "%" & Chr(34) & "," & Chr(34) & Chr(34) & "))," & Chr(34) & Chr(34) & ")"

 

[cmowla]

Okay, then. I will let someone else give it a try. It works from my end (based on how I am guessing your sheet looks). Have a good night.