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

Burrgogi

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

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
Sort by date Sort by votes
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
cmowla said:
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.
Click to expand...

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
cmowla said:
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.
Click to expand...

Sorry, my bad. I meant to say from Col. C to Col E.
 
Upvote 0
cmowla said:
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
Click to expand...


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
You must log in or register to reply here.

Similar threads

Burrgogi
  • Solved
How to insert formula to show value and also account for instances of 2 digits versus 3 digits.
Replies
6
Views
486
JoeMo
J
Burrgogi
  • Question Question
VBA routine throws up error if workbook is open
Replies
4
Views
445
Burrgogi
Burrgogi
Burrgogi
  • Question Question
VBA sorting problem and moving rows based on criteria
Replies
5
Views
1K
Burrgogi
Burrgogi
A
  • Solved
Formula not calculating after VBA. Need to click each cell
2
Replies
10
Views
2K
Alex Blakenburg
A
J
  • Solved
vba - sum formula works in debug mode but not when I actually run the full macro
Replies
5
Views
1K
Fluff
Fluff

Forum statistics

Threads
1,223,903
Messages
6,175,284
Members
452,630
Latest member
OdubiYouth

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