Solved it. Here's the solution if anyone ever comes across this:
Had to rewrite the formula to use the variable pTable reference by adding "& pTable&" to pull the variable name into the formula
DeathCalc = "=NewTable[[#Totals],[Death as % of Total Cases]] -" & pTable & "[[#Totals],[Death as % of Total Cases]]"Ok, now it looks like the error is in the formula. If I change it to a generic formula, it works.
Update: I've partially solved my problem but am stumped at the error I get now.
I now get the RunTime Error 1004 application defined or object defined error when I get to this line:
Range("NewChange[[#Totals],[Death as % of Total Cases]]").FormulaR1C1 = DeathCalcI am completely baffled, because it is the exact same syntax as I used in the two lines above it and those work 100% perfect. What am I doing wrong??
Dim nChangeNew As ListObject
Dim nTableNew As ListObject
Dim pTableDate As String '//Calculates date value for prior day table name
Dim pTableName As String '//Sets table name for prior day table based on dateadd calc from pTableDate
Dim pTable As ListObject '//Sets table as listobject for prior day table for death rate change calc
Dim DeathCalc As String '//defines formula to enter into death rate change of nChangeNew table
Dim ws As Worksheet
pTableDate = DateAdd("d", -1, Date)
pTableName = "Cases" & Format(pTableDate, "mmddyy")
Set ws = ActiveWorkbook.Sheets(8)
Set pTable = ws.ListObjects(pTableName)
Set nChangeNew = ws.ListObjects("NewChange")
Set nTableNew = ws.ListObjects("NewTable")
DeathCalc = "=nTableNew[[#Totals],[Death as % of Total Cases]]-pTable([[#Totals],[Death as % of Total Cases]]"
Range("NewChange[[#Totals],[Cases ]]").FormulaR1C1 = "=SUBTOTAL(109,[Cases ])"
Range("NewChange[[#Totals],[Deaths]]").FormulaR1C1 = "=SUBTOTAL(109,[Deaths])"
Range("NewChange[[#Totals],[Death as % of Total Cases]]").FormulaR1C1 = DeathCalc
nChangeNew.DataBodyRange(1, 2).FormulaR1C1 = "=R[-57]C-R[-57]C[-5]"
nChangeNew.DataBodyRange(1, 3).FormulaR1C1 = "=R[-57]C-R[-57]C[-5]"
nChangeNew.DataBodyRange(1, 4).FormulaR1C1 = "=R[-57]C-R[-57]C[-5]"I have a macro that adds a 2 new tables to a sheet, a new table for each day to the right of the previous day tables (the 2 daily tables are vertically stacked). There are total rows in the new tables, and I need to insert a formula that calculates the difference between one of the total columns for the new day and the previous day's total. I recorded a macro that I planned to edit to include variable references rather than fixed references. I'm now stuck at how to address the second part of the formula below:
Cases051920[[#Totals],[Death as % of Total Cases]]The "Cases051920" table name is the variable. Each day, it will be a different date. Today's is "Cases052020", and tomorrow's new table will need to reference this table - and so on. How do I turn this into a variable so the macro can insert the formula so that it references the correct prior day's table???
This is the recorded bit of code that I'm trying to adapt:
Range("NewChange[[#Totals],[Death as % of Total Cases]]").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = _
"=NewTable[[#Totals],[Death as % of Total Cases]]-Cases051920[[#Totals],[Death as % of Total Cases]]"Ohh thank you so much. This is so close, I just need some help adapting it to my scenario. There are red cells in various columns, but I only want to sort color based on Column M and then ascending number in Column L next. And rather than loop through all sheets (there are 5 total) I only want this specific sheet. I think I've done that with requiring the ws.name to be the correct sheet name before applying sort. Here's what I have so far.
I'm planning to call this private sub from my main macro rather than integrate the code into my existing macro. Is that a good idea?
Private Sub VGPCGSort()
Dim ws As Worksheet
Dim i As Integer
Dim lw As Long
For Each ws In Sheets
If ws.Name = "VGP" Then
lw = ws.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To ws.Cells(1, Columns.Count).End(xlToLeft).Column
ws.Sort.SortFields.Clear
ws.Sort.SortFields.Add(Range(ws.Cells(1, i), ws.Cells(lw, i)), 1, 2, 1).SortOnValue.Color = RGB(255, 0, 0)
ws.Sort.SetRange ws.Range(ws.Cells(1, i), ws.Cells(lw, i))
ws.Sort.Apply
Next i
Next ws
End SubI've spent wayy too long searching for why my code isn't always working. The scenario is that I have a sheet (VGP) with Columns A:U. The number of rows is dynamic each time I use this. I need to sort the entire range by the cell color in Column M (RGB 255,0 ,0) so that they appear at the top of the sheet first. Then, I need Column L to sort the numerical values in ascending order. I have 2 bits of code in my macro that work with varying degrees of success. This first section works sometimes. Then doesn't. It will have Column L sorted in numerically ascending order, but Column M will be all over the place in whatever order Column L is in.
So I turned to trying to sort by the cell color, because the cells that populate with "CG Trip Risk" in Column M based on the formulas in that column fill with a red background. I end up with a similar result, where it doesn't seem to be sorting by cell color first. The second section of code below is this attempt.
The last section of code below contains the section above where the sort functions begin, where the formula is input that results in the "CG Trip Risk" string and the red background color. I've also included a sample file containing the sheet and data with how it looks after running the macro currently.
I've searched all over the interwebs and tried dozens and dozens of different combinations with the same result, what am I missing?! Thank you!
'//First attempt, by cell value rather than color
Sheets("VGP").Range("A1:U" & Sheets("VGP").Range("A1").End(xlDown).Row).Sort _
Key1:=Sheets("VGP").Range("M:M"), Order1:=xl, _
key2:=Sheets("VGP").Range("L:L"), order2:=xlAscending, _
Header:=xlYes
'//Second Sort Code by Color
ActiveWorkbook.Worksheets("VGP").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("VGP").Sort.SortFields.Add(Range("M2"), _
xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, 0 _
, 0)
ActiveWorkbook.Worksheets("VGP").Sort.SortFields.Add Key:=Range("L2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("VGP").Sort
.SetRange Range("A1").CurrentRegion
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'//Code above sort sections
Columns("M:M").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("N:N").Select
Selection.TextToColumns Destination:=Range("N1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Columns("L:L").Select
Selection.TextToColumns Destination:=Range("L1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Range("L1").Select
ActiveCell.FormulaR1C1 = "# VINs to Exact Tier Attainment" '//Added this to re-define the "Diff(EligUnits-ReqToTrip)" header
Columns("L:L").Select
Selection.ColumnWidth = 10
Columns("L:L").EntireColumn.AutoFit
Range("M1").Select
ActiveCell.FormulaR1C1 = "Total # CG Codes > # Units to Tier Attain"
Range("M2").Select
ActiveCell.FormulaR1C1 = _
"=IF(AND(ISNUMBER(RC[1]), RC[1]>RC[-1]), ""CG Trip Risk"", """")"
Selection.AutoFill Destination:=Range("M2:M" & Range("A" & Rows.Count).End(xlUp).Row)
Range(Selection, Selection.End(xlDown)).Select '//This & 2 lines above autofill formula in M2 to range of A
Columns("M:M").EntireColumn.AutoFit
Columns("L:L").Select
Selection.NumberFormat = "0"
Columns("M:M").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""CG Trip Risk"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.Bold = True
.Italic = False
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
End If
'Sheets("VGP").Range("A1:U" & Sheets("VGP").Range("A1").End(xlDown).Row).Sort _
'Key1:=Sheets("VGP").Range("M:M"), Order1:=xl, _
'key2:=Sheets("VGP").Range("L:L"), order2:=xlAscending, _
'Header:=xlYes
ActiveWorkbook.Worksheets("VGP").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("VGP").Sort.SortFields.Add(Range("M2"), _
xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, 0 _
, 0)
ActiveWorkbook.Worksheets("VGP").Sort.SortFields.Add Key:=Range("L2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("VGP").Sort
.SetRange Range("A1").CurrentRegion
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With Success! Added that to my code, and also added if/else prior to the formatting for the A9 & OTJ sheets and now it all works again! Thanks for your help.
If Range("A2") = "" Then '//Fills cell A2 with "NO DATA" and prevents formatting code from running if there is no data.
Range("A2").Value = "NO DATA FOR DEALER CODE"
Range("A2").Font.Bold = True
Range("A2").Interior.ColorIndex = 27
Range("A2").Borders.Color = vbBlack
Range("A2").Borders.Weight = xlThick
Cells.EntireColumn.AutoFit
Rows("1:1").Font.Strikethrough = True
Else
'//Remaining code followsWhere would be the correct place in my code to add this is?
Sub DAR_Automation_Prod() '//BPD version 1.0.3 4/6/20
Dim oWb As Workbook, oNewWb As Workbook
Dim oWs As Worksheet
Dim rRng As Range
Dim iX As Integer
Dim sCode As String, vNewname
Dim cell As Range
On Error GoTo exit_proc
Application.ScreenUpdating = False
''// The activeworkbook MUST be the desired BC workbook
Set oWb = ActiveWorkbook
''//create new workbook
Set oNewWb = Workbooks.Add
''//add 5 sheets
Application.SheetsInNewWorkbook = 5
sCode = InputBox("Enter Dealer Code", "Filter Criteria") '//Controls input box that appears to enter dealer code
If sCode = Empty Then
MsgBox "No Dealer Code Entered", vbCritical, "Process Cancelled by User"
ActiveWorkbook.Close False
Exit Sub
End If
iX = 1
For Each oWs In oWb.Worksheets
With oWs
If Not .AutoFilterMode Then .Range("A1").AutoFilter
.Range("A1").AutoFilter Field:=1, Criteria1:=sCode
Set rRng = .AutoFilter.Range
rRng.Copy
With oNewWb
.Sheets(iX).Range("A1").PasteSpecial xlAll
.Sheets(iX).Range("A1").CurrentRegion.Cells.WrapText = False
.Sheets(iX).Range("A1").CurrentRegion.Columns.AutoFit
.Sheets(iX).Name = oWs.Name
End With
iX = iX + 1
End With
Next oWs
Dim sh As Worksheet
For Each sh In oWb.Worksheets
If sh.AutoFilterMode Then
sh.AutoFilter.Range.AutoFilter
End If
Next
vNewname = Application.GetSaveAsFilename(filefilter:="Excel Files(*.xlsx), *.xlsx") '//Brings up save as dialog box
If vNewname <> False Then ActiveWorkbook.SaveAs Filename:=vNewname, FileFormat:=51
exit_proc:Here is the part of the code that you helped me put together originally. I have a source workbook with 5 sheets of data, that we filter based on a specific "dealer code", copy the data from all 5 sheets, and paste into a new workbook. Commonly, there is no filtered data under 2 of the tabs for the specified dealer code (A9 and OTJ). In those instances, all that gets copied is the header row which is then pasted into the new workbook. In the attached workbook "Error Test 3", the sheet "A9" is what it looks like when there is no data to copy/paste.
I have also included an example of the source workbook.
My thought is to somehow run through each sheet after filtering by dealer code, and if cell A2 is blank, then skip the copy/paste for that sheet.
OR when formatting the new workbook sheets, first check if cell A2 on each sheet is blank and skip the section of formatting code for that sheet if it is blank.
Option Explicit
Sub DAR_Automation_Prod() '//BPD version 1.0.3 4/6/20
Dim oWb As Workbook, oNewWb As Workbook
Dim oWs As Worksheet
Dim rRng As Range
Dim iX As Integer
Dim sCode As String, vNewname
Dim cell As Range
On Error GoTo exit_proc
Application.ScreenUpdating = False
''// The activeworkbook MUST be the desired BC workbook
Set oWb = ActiveWorkbook
''//create new workbook
Set oNewWb = Workbooks.Add
''//add 5 sheets
Application.SheetsInNewWorkbook = 5
sCode = InputBox("Enter Dealer Code", "Filter Criteria") '//Controls input box that appears to enter dealer code
If sCode = Empty Then
MsgBox "No Dealer Code Entered", vbCritical, "Process Cancelled by User"
ActiveWorkbook.Close False
Exit Sub
End If
iX = 1
For Each oWs In oWb.Worksheets
With oWs
If Not .AutoFilterMode Then .Range("A1").AutoFilter
.Range("A1").AutoFilter Field:=1, Criteria1:=sCode
Set rRng = .AutoFilter.Range
rRng.Copy
With oNewWb
.Sheets(iX).Range("A1").PasteSpecial xlAll
.Sheets(iX).Range("A1").CurrentRegion.Cells.WrapText = False
.Sheets(iX).Range("A1").CurrentRegion.Columns.AutoFit
.Sheets(iX).Name = oWs.Name
End With
iX = iX + 1
End With
Next oWs
Dim sh As Worksheet
For Each sh In oWb.Worksheets
If sh.AutoFilterMode Then
sh.AutoFilter.Range.AutoFilter
End If
Next
vNewname = Application.GetSaveAsFilename(filefilter:="Excel Files(*.xlsx), *.xlsx") '//Brings up save as dialog box
If vNewname <> False Then ActiveWorkbook.SaveAs Filename:=vNewname, FileFormat:=51
exit_proc:Some of the formatting can probably be done to the source workbook, I'll experiment with that. What I'm noticing after digging in further, is that the content error only comes up when there was no data available in the source workbook for that A9 sheet. The headers get copied & pasted to the new workbook, but there is no data. When there IS data there, the workbook opens with no error. Is there a better way to handle the occurrences where there is no data to paste into the new A9 sheet? Where it skips the formatting steps and moves to the next sheet?
Ok, I'm narrowing in on the section of code that is triggering the issue. I deleted all my code and started fresh with the original code you sent me last month. Then I started adding sections of code back in one sheet at a time until the error triggered again. When I added this section of code in to format the "A9" sheet, this is when I start getting the error when I try to re-open the file. Any thoughts?
'//Begin A9 Formatting
Sheets("A9").Select
Cells.Select
Selection.ColumnWidth = 62
Cells.EntireColumn.AutoFit
Cells.EntireRow.AutoFit
Rows("1:1").Select
Application.CutCopyMode = False
With Selection
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("O1").Select
ActiveCell.FormulaR1C1 = "Notes"
Range("N1").Select
Selection.Copy
Range("O1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Columns("O:O").ColumnWidth = 35
Columns("O:O").Select
With Selection
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("B:B,I:I").Select
Range("I1").Activate
Selection.EntireColumn.Hidden = True
Columns("D:D").Select
Selection.ColumnWidth = 7
Rows("1:1").RowHeight = 14
Rows("1:1").EntireRow.AutoFit
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").Select
Selection.ColumnWidth = 8
Rows("1:1").EntireRow.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("J:J").Select
Selection.ColumnWidth = 8
Selection.ColumnWidth = 10
Columns("J:J").EntireColumn.AutoFit
Columns("K:K").Select
Selection.ColumnWidth = 13
Columns("K:K").EntireColumn.AutoFit
Range("A1").Select
Selection.AutoFilter
ActiveWorkbook.Worksheets("A9").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("A9").AutoFilter.Sort.SortFields.Add Key:=Range( _
"K:K"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("A9").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").SelectGreat, I'll give that a try. Anything to help clean up the code and speed the program up. Thanks Roy!
Hoping this is posted in the correct location.
I have a macro that creates a new workbook and pastes & formats data to 5 new sheets. It has been working flawlessly for a few weeks now. (I have attached a .txt file with the VBA script for the macro that generates the file - it is too long to enter with code tags). Until this particular file that I created today. For whatever reason, I get an error that there is a problem with some content. It only does this for this particular file, no matter how many times I delete and re-generate the file. I've tested dozens of others, and it still works.
Here is a screenshot of the message that pops up when I first open the file:
After repairing, a message confirming the repair with a link to the log file opens and this is the text within the log file:
I've been searching for a while this morning trying to figure out what it's having trouble with. There is no VBA code stored in the file that is generated, and no xml objects (at least that I can find).
The excel file that I attached brings up the error when I've tested it a few times.
How do I go about finding the issue that excel is finding?
I have a set of data that has a column of State abbreviations in it. Each state abbreviation has a corresponding numerical value. I am trying to use looping If/ElseIf to determine the state abbreviation in one column, and based on the value, return the assigned numerical value to the empty cell next to it. With the code below, I get a run-time error 13 Type mismatch with the first IF line highlighted. I've spent most of the day searching for an answer, and the closest that I get is that I have an issue with the text vs. number value and I'm not sure how to solve it.
I have include a sample workbook with the data that I'm referencing.
Sub AuditLimits()
For Each Cell In Range("E2:E2634")
If Cell.Value = "UT" Or "MD" Or "NM" Or "VA" Then
Cell.Offset(0, 1).Val = "6"
ElseIf Cell.Value = "PA" Or "NV" Or "CO" Or "CA" Or "NH" Then
Cell.Offset(0, 1).Value = "9"
ElseIf Cell.Value = "TN" Or "ND" Or "IA" Or "OH" Or "MS" Or "SC" Or "NE" Or "IL" Or "FL" Or "CT" Or "OR" Or "MO" Or "WV" Or "IN" Or "KY" Or "MT" Or "NJ" Or "AZ" Or "NC" Or "AL" Or "ID" Or "DC" Or "WA" Or "ME" Or "RI" Or "LA" Or "TX" Or "MA" Or "NY" Or "DE" Or "KS" Or "MI" Or "MN" Or "GA" Or "HI" Or "OK" Or "SD" Or "AR" Then
Cell.Offset(0, 1).Value = "12"
ElseIf Cell.Value = "AK" Or "VT" Then
Cell.Offset(0, 1).Value = "18"
ElseIf Cell.Value = "EX" Or "GU" Or "WI" Or "PR" Or "WY" Then
Cell.Offset(0, 1).Value = "24"
End If
Next Cell
End SubIt's in the file I attached above, but I included it here again. It was too long to paste into code tags, exceeded 10,000 characters. It starts at the end of the sub you wrote.
Yeah, it's not there. It's not in the source file to begin with. The 9 master files get exported to a shared network drive from QlikSense through nPrinting that turns them into what you see in the example file. Then based on a request I get the data for the necessary dealer code and create a report for that particular request. I've tried applying all the formatting to the master files but they contain so much data that it sometimes locks excel up.
Perfect. As far as formatting, it's a lot of clean up stuff - moving come columns around, applying conditional formatting, centering, level-sorting, things like that. It's working AMAZINGLY now. Thank you so much for your help with this.
I played around with this some more and attempted to add my formatting macros to the script. Unbelievable - but it runs in about 10 seconds including the time to enter the file name in the save as dialog. I tried adding it with code tags, but it's too long. Here's a sample file with it embedded.
One question - when the save as dialog box opens, it defaults to "All Files (*.*)" as the save-as type and I have to type .xlsx after my file name to get it to save as excel.. How do I get that to default to .xlsx?
Oh I know, I was just amazed that I managed to frankenstein together a program that would do what I needed it to. I'm sure I'll be back as I keep working on this project. Thanks again!