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

Burrgogi

Active Member
Joined
Nov 3, 2005
Messages
495
Office Version
  1. 2010
Platform
  1. Windows
VBA Code:
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%).
 

Excel Facts

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".
Hi.

Let me know if this does the task as intended:
VBA Code:
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
 
Upvote 0
Doesn't work.

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

Doesn't like the following line of code:

VBA 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) & ")"
 
Upvote 0
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:
VBA Code:
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:
VBA Code:
Call Pause(4)

Below the line of code:
VBA Code:
ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False

And let me know if that works.
 
Upvote 0
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?
 
Upvote 0
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:
VBA Code:
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
 
Upvote 0
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.
 
Upvote 0
VBA Code:
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:

VBA Code:
 .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) & ")"
 
Upvote 0
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.
 
Upvote 0

Forum statistics

Threads
1,223,236
Messages
6,170,915
Members
452,366
Latest member
TePunaBloke

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