I am struggling with applying a previous bit of code I have used for the same process in a different workbook.
The process is that I have conditionally formatted a set of information (now on a different sheet) to change colour based on whether either "Lab" or "Office" is selected from the drop down list.
I then wanted (what I believe this code should do however I don't believe I have linked the series correctly) the graph which the information is in relation too to change the relevant data points to that colour, highlighting that on this floor you have selected "Office" or "Lab".
The code I am using starts here:
Sub CellColorsToChart()
Dim xChart As Chart
Dim I As Long, J As Long
Dim xRowsOrCols As Long, xSCount As Long
Dim xRg As Range, xCell As Range
On Error Resume Next
Set xChart = ActiveSheet.ChartObjects("Net Internal Area").Chart.Refresh
If xChart Is Nothing Then Exit Sub
xSCount = xChart.SeriesCollection.Count
For I = 1 To xSCount
J = 1
With xChart.SeriesCollection(I)
Set xRg = ActiveSheet.Range(Split(Split(.Formula, ",")(2), "!")(1))
If xSCount > 4 Then
xRowsOrCols = xRg.Columns.Count
Else
xRowsOrCols = xRg.Rows.Count
End If
For Each xCell In xRg
.Points(J).Format.Fill.ForeColor.RGB = ThisWorkbook.Colors(xCell.DisplayFormat.Interior.ColorIndex)
.Points(J).Format.Line.ForeColor.RGB = ThisWorkbook.Colors(xCell.DisplayFormat.Interior.ColorIndex)
J = J + 1
Next
End With
Next
End Sub
Document can be downloaded here: https://wetransfer.com/downloads/fbdb338026e7c42cc08193536270cdfc20211115102313/07937d
Any help or tips on how to understand and read this better would be amazing.
Best
Jack
Remove Refresh from this line Set xChart = ActiveSheet.ChartObjects("Net Internal Area").Chart.Refresh and refresh chart after If xChart Is Nothing Then Exit Sub
Option Explicit
Sub CellColorsToChart()
Dim xChart As Chart
Dim I As Long, J As Long, ix As Long
Dim xSCount As Long
Dim xRg As Range, xCell As Range
Set xChart = ActiveSheet.ChartObjects("Net Internal Area").Chart
If xChart Is Nothing Then Exit Sub
xChart.Refresh
xSCount = xChart.SeriesCollection.Count
For I = 1 To xSCount
With xChart.SeriesCollection(I)
J = 1
Set xRg = ActiveSheet.Range(Split(Split(.Formula, ",")(2), "!")(1))
For Each xCell In xRg
ix = xCell.DisplayFormat.Interior.ColorIndex
If ix >= 1 Then
.Points(J).Format.Fill.ForeColor.RGB = ThisWorkbook.Colors(ix)
.Points(J).Format.Line.ForeColor.RGB = ThisWorkbook.Colors(ix)
End If
J = J + 1
Next
End With
Next
End Sub
Related
Summary. I am trying to loop through a table and delete each row if a particular substring is found in a specified column. I am specifically stuck on the line of code that finds the target text, which I know to be incorrect, but cannot find the proper syntax for what I'm trying to achieve: If tbl.DataBodyRange(rw, 10).Find(myString)
I have searched many websites and YouTube videos, and there are a few that address finding an exact value, but nothing I could find like the problem I'm trying to solve.
My code:
Sub removeTax()
Dim tbl As ListObject
Set tbl = ThisWorkbook.Sheets("Master").ListObjects("tblMaster")
Dim myString As String
myString = "Tax"
Dim rw
For rw = tbl.DataBodyRange.Rows.Count To 1 Step -1
If tbl.DataBodyRange(rw, 10).Find(myString) Then
tbl.ListRows.Delete
End If
Next
End Sub
Thank you very much for any assistance you can offer.
Delete Criteria Rows of an Excel Table (ListObject)
As an alternative, this uses a method that uses AutoFilter and SpecialCells.
Usage
Sub RemoveTax()
Const CritColumn As Long = 10
Const CritString As String = "*Tax*" ' contains
Dim tbl As ListObject
Set tbl = ThisWorkbook.Worksheets("Master").ListObjects("tblMaster")
DeleteTableCriteriaRows tbl, CritColumn, CritString
End Sub
The Method
Sub DeleteTableCriteriaRows( _
ByVal Table As ListObject, _
ByVal CriteriaColumn As String, _
ByVal CriteriaString As String)
With Table
If .ShowAutoFilter Then
If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData
Else
.ShowAutoFilter = True
End If
.Range.AutoFilter CriteriaColumn, CriteriaString
Dim rg As Range
On Error Resume Next
Set rg = .DataBodyRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
.AutoFilter.ShowAllData
If Not rg Is Nothing Then rg.Delete xlShiftUp
End With
End Sub
I've corrected your approach, it checks if myString is sub-string of values in column 10
With tbl.DataBodyRange.Columns(10)
For rw = .Rows.Count To 1 Step -1
If InStr(1, .Cells(rw).Value2, myString) > 0 Then
tbl.ListRows(rw).Delete
End If
Next rw
End With
Keep in mind, you should check if tbl.DataBodyRange is not Nothing, before doing anything with it, since deleting all rows of a table makes DataBodyRange be equal to Nothing
I've decided to make a bit more efficient solution, more to my liking
Sub RemoveTaxQuicker()
Const myString = "Tax"
Dim tbl As ListObject
Set tbl = ThisWorkbook.Sheets("Master").ListObjects("tblMaster")
If tbl.DataBodyRange Is Nothing Then: Exit Sub
Dim rowsRangeString As String
Dim i As Long
Dim C10 As Variant
C10 = tbl.DataBodyRange.Columns(10).Value2
Dim rng As Range
If IsArray(C10) Then
Set rng = Nothing
For i = LBound(C10) To UBound(C10)
If InStr(1, C10(i, 1), myString) > 0 Then
If rng Is Nothing Then
Set rng = tbl.DataBodyRange.Cells(i, 1)
Else
Set rng = Union(rng, tbl.DataBodyRange.Cells(i, 1))
End If
End If
Next i
If Not rng Is Nothing Then
rng.Delete xlUp
End If
ElseIf InStr(1, C10, myString) > 0 Then
tbl.ListRows(1).Delete
End If
End Sub
This is no longer true :) You should use #VBasic2008 approach, I've tested it on 500k rows and it takes around 10 sec or so. And I had to test mine as well (was painfully long), it took ~5 mins. :)
Okay VBasic2008's solution forced me to think about this in a different way. The following solution executes almost instantly.
'works with formulas as well with some exceptions, thanks VBasic for pointing that as a potential problem
Sub RemoveTaxQuicker2()
Const myString = "Tax"
Const COLUMN = 10
Dim tbl As ListObject
Set tbl = ThisWorkbook.Sheets("Master").ListObjects("tblMaster")
If tbl.DataBodyRange Is Nothing Then: Exit Sub
Dim i As Long, j As Long
Dim count As Long
Dim sDataBody As Variant
Dim sFormulas As Variant
sDataBody = tbl.DataBodyRange.Formula
sFormulas = tbl.ListRows(1).Range.Formula
If tbl.DataBodyRange.Rows.count > 1 Then
For i = LBound(sDataBody, 1) To UBound(sDataBody, 1)
If InStr(1, sDataBody(i, COLUMN), myString) < 1 Then
count = count + 1
For j = LBound(sDataBody, 2) To UBound(sDataBody, 2)
sDataBody(count, j) = sDataBody(i, j)
Next j
End If
Next i
If count > 0 Then
For i = LBound(sFormulas, 2) To UBound(sFormulas, 2)
If Left$(sFormulas(1, i), 1) = "=" Then
sDataBody(1, i) = sFormulas(1, i)
End If
Next i
tbl.DataBodyRange.Formula = sDataBody
If tbl.ListRows.count > count Then
tbl.ListRows(count + 1).Range.Resize(tbl.ListRows.count).ClearContents
tbl.Resize tbl.Range.Resize(count + 1)
End If
End If
ElseIf InStr(1, sDataBody(1, COLUMN), myString) > 0 Then
On Error Resume Next
tbl.DataBodyRange.SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo 0
End If
End Sub
Final note: I still prefer VBasic's method, if nothing else it's much cleaner and it works when the table is full of formulas that are not auto-filled :)
I want to check the status of a sheet and when changed automatically run some calculations. I also wish refresh a graph with the new data from that sheet.
I used the Worksheet_Change function. It calls the sub with the calculations and calls the sub that contains the chart modification code. They run as planned with one exception. The range that gets passed to the Chrt1 sub (responsible for the chart functionality) does not get updated on the graph once it has been called out for the first time.
I'm aware that this can be overcome with Excel built-in tables function but I'd like to code this simple routine in anyways.
The Worksheet_Change function:
Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
AutoChangeTest
Application.EnableEvents = True
End Sub
The main module code:
Sub AutoChangeTest()
Dim s1 As Worksheet, s2 As Worksheet
Dim i As Integer, j As Integer, lrow As Integer, lrow2 As Integer
Set s1 = Sheets("Arkusz3")
On Error GoTo Err1
lrow = s1.Cells(s1.Rows.Count, 1).End(xlUp).Row
For i = 1 To lrow
s1.Cells(i, 2) = s1.Cells(i, 1) * 2
Next
Call Chrt1(Range(s1.Cells(1, 1), s1.Cells(lrow, 2)), s1)
Err1:
If Not IsNumeric(s1.Cells(i, 1)) Then
s1.Cells(i, 1).Activate
End If
End Sub
Sub Chrt1(r1 As Range, s1 As Worksheet)
Dim c1 As Shape
Dim s As Worksheet
Dim cht As ChartObject
Dim i As Integer
i = 0
Set r = r1
Set s = s1
For Each cht In s.ChartObjects
i = i + 1
Next
If i = 0 Then
Set c1 = s.Shapes.AddChart
End If
c1.Chart.SetSourceData (r)
End Sub
Some suggestions in the code below:
Sub AutoChangeTest()
Dim ws As Worksheet 'avoid variable names with 1/l - too unclear
Dim i As Long, lrow As Long 'always use long over integer
Set ws = ThisWorkbook.Worksheets("Arkusz3")
lrow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
On Error GoTo exitHere
Application.EnableEvents = False 'don't re-trigger this sub...
For i = 1 To lrow
With ws.Cells(i, 1)
'easier to test than to trap an error if non-numeric
If IsNumeric(.Value) Then
ws.Cells(i, 2) = .Value * 2
Else
ws.Select
.Select
MsgBox "Non-numeric value found!"
GoTo exitHere 'acceptable use of Goto I think
End If
End With
Next
'don't think you need a separate method for this...
If ws.ChartObjects.Count = 0 Then ws.Shapes.AddChart 'no need to loop for a count
'assuming there will only be one chart...
ws.ChartObjects(1).Chart.SetSourceData ws.Range(ws.Cells(1, 1), ws.Cells(lrow, 2))
exitHere:
If Err.Number <> 0 Then Debug.Print Err.Description
Application.EnableEvents = True
End Sub
In your Chrt1 procedure, this bit
For Each cht In s.ChartObjects
i = i + 1
Next
If i = 0 Then
Set c1 = s.Shapes.AddChart
End If
can be replaced by the following:
If s.ChartObjects.Count = 0 Then
Set c1 = s.Shapes.AddChart
End If
But what is c1 if you don't have to add a chart? You haven't defined it, and the On Error means you never find out that it's broken.
Assuming you want the last chart object to be the one that is changed:
If s.ChartObjects.Count = 0 Then
Set c1 = s.Shapes.AddChart
Else
Set c1 = s.ChartObjects(s.ChartObjects.Count)
End If
And you should declare c1 as a ChartObject.
Finally, remove the parentheses around r in this line:
c1.Chart.SetSourceData r
Thank you all for support. The basic code that works is shown below. It isn't the best looking but it does the job.
Sub Chrt1(r1 As Range, s1 As Worksheet)
Dim c1 As Shape
Dim s As Worksheet
Dim cht As ChartObject
Dim i As Integer
i = 0
Set r = r1
Set s = s1
For Each cht In s.ChartObjects
i = i + 1
Next
If i = 0 Then
Set c1 = s.Shapes.AddChart
End If
Set cht = s.ChartObjects(1)
cht.Chart.SetSourceData Source:=r
End Sub
I have a chart with 2 data series that reference cell values with conditional formatting to determine its color. I looked up a VBA code on the net to use on the chart to update the colors of the series based on the cell color, but when running the code nothing happens.
Anybody can help me with this?
Sub CellColorsToChart()
'Updateby Extendoffice
Dim xChart As Chart
Dim I As Long, J As Long
Dim xRowsOrCols As Long, xSCount As Long
Dim xRg As Range, xCell As Range
On Error Resume Next
Set xChart = ActiveSheet.ChartObjects("Chart 2").Chart
If xChart Is Nothing Then Exit Sub
xSCount = xChart.SeriesCollection.Count
For I = 1 To xSCount
J = 1
With xChart.SeriesCollection(I)
Set xRg = ActiveSheet.Range(Split(Split(.Formula, ",")(2), "!")(1))
If xSCount > 4 Then
xRowsOrCols = xRg.Columns.Count
Else
xRowsOrCols = xRg.Rows.Count
End If
For Each xCell In xRg
.Points(J).Format.Fill.ForeColor.RGB = ThisWorkbook.Colors(xCell.Interior.ColorIndex)
.Points(J).Format.Line.ForeColor.RGB = ThisWorkbook.Colors(xCell.Interior.ColorIndex)
J = J + 1
Next
End With
Next
End Sub
xCell.Interior references the cells applied color, not a conditional format.
If you are using Excel 2010+ then you should use .DisplayFormat to get the conditional format color.
Also, why bother with ThisWorkbook.Colorsand ColorIndex, just reference the color:
.Points(J).Format.Fill.ForeColor.RGB = xCell.DisplayFormat.Interior.Color
Also, after you set On Error Resume Next to trap an error on Set xChart =, you must reset the error handling
On Error Resume Next
Set xChart = ActiveSheet.ChartObjects("Chart 2").Chart
On Error GoTo 0 ' <~~ reset error handling
If xChart Is Nothing Then Exit Sub
I have a simple macro that refuses to work. It gets to the cut portion and surrounds the information with marching ants; and then...nothing.
What I am trying to accomplish is to find a value (1050) in column D. Whenever I find it, I want to move the entire row of data to the bottom of the sheet.
The worksheet consists of thousands of lines of information and the number of rows changes every month. The columns are constant.
This is what I have:
Sub MurrayTest()
'Dim xRg As Range
'Dim xTxt As String
'Dim xCell As Range
'Dim xEndRow As Long
'Dim I As Long
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Range("d:d")
xEndRow = xRg.Rows.Count + xRg.Row
Application.ScreenUpdating = False
For I = xRg.Rows.Count To 1 Step -1
If xRg.Cells(I) = "1050" Then
xRg.Cells(I).EntireRow.Cut
Rows(xEndRow).Insert Shift:=xlDown
End If
Next
Application.ScreenUpdating = True
End Sub
Any assistance would be greatly appreciated!
Your problem is that you are trying to insert the rows into the last row of the sheet +1. This is out of bounds.
Instead of this:
Set xRg = Range("d:d")
xEndRow = xRg.Rows.Count + xRg.Row
Do this:
Set xRg = Range("d:d")
xEndRow = Range("d1").End(xlDown).Row + 1
This way your just looking at populated cells instead of all possible cells.
Note
I prefer using something like xEndRow = Cells(Rows.Count, 1).End(xlUp).Row because finding the last row from the top can sometimes be incorrect if the dataset isn't complete. You may need to play with different approaches to determine what's best for your situation.
If i read this correctly, you want to find the value 1050 on Column D, if it is found you want this row Cut and Inserted at the end of the list.
Sub MurrayTest()
Dim xRg As Range
Dim xEndRow As Long
Dim i As Long
Set xRg = Range("D:D")
xEndRow = Cells(Rows.Count, 4).End(Excel.xlUp).Row + xRg.Row
Application.ScreenUpdating = False
For i = xEndRow To 1 Step -1
If xRg.Cells(i) = "1050" Then
xRg.Cells(i).EntireRow.Cut
Rows(xEndRow).Insert Shift:=xlDown
End If
Next
Application.ScreenUpdating = True
End Sub
I tried to get the unique value of each column in the range "RD" and display them in single column. I need to create an object ("scripting.Dictionary") where there are just as many as the number of columns in Range "RD". I tried this code but it resulted in "Run time error 13".
Private Sub CommandButton1_Click()
Range(Me.RefEdit1).Name = "RD"
Range(Me.RefEdit2).Name = "OT"
Dim d As Object, c As Variant, i As Long, s As Long
Dim JK As Long
Dim o As Collection
JK = Range("RD").Columns.Count
Set d = CreateObject("Scripting.Dictionary")
For k = 0 To JK + 1
d.Item(k) = CreateObject("Scripting.Dictionary").Item(k)
c = Range("RD").Columns(k + 1)
If d.Exists(k) Then
d.Item(k) = d.Item(k) + 1 'increment
Else
d.Item(k) = 1 'set as 1st occurence
End If
For i = 1 To UBound(c, 1)
d.Item(k)(c(i, 1)) = 1
Next i
Range("OT").Cells((k * 5) + 2, 2).Resize(d.Item(k).Count) = Application.Transpose(d.Item(k).Keys)
Range("OT").Cells((k * 5) + 2, 2).Resize(d.Item(k).Count).Sort Key1:=Range("OT").Cells((k * 5) + 2, 2).Resize(d.Item(k).Count)
Next k
End Sub
I'm adding some code below to help loop through a list, looking for unique values, and adding them to a new column. In my example, I enclose the entire functionality into a single loop for efficiency. I'm also adding the unique values to a new column in Sheet2 starting with cell A1.
Let me know if you need any additional help.
EDITED CODE BASED ON A MISUNDERSTANDING:
Private Sub CommandButton1_Click()
Dim oDict As Object
Dim rngToScrub As Range
Dim rngNewColumnToStoreUnique As Range
Dim oCol As Range
Dim cel As Range
Set rngToScrub = Range(Me.RefEdit1.Value)
Set rngNewColumnToStoreUnique = Sheet2.Range("A1")
For Each oCol In rngToScrub.Columns
Set oDict = CreateObject("Scripting.Dictionary")
For Each cel In oCol.Cells
If oDict.exists(cel.Value) Then
'Do Nothing for Now
Else
oDict.Add cel.Value, 0
rngNewColumnToStoreUnique.Value = cel.Value
Set rngNewColumnToStoreUnique = rngNewColumnToStoreUnique.Offset(1)
End If
Next cel
Set oDict = Nothing
Next oCol
End Sub
Old code: Misunderstood requirements
Private Sub CommandButton1_Click()
Dim oDict As Object
Dim rngToScrub As Range
Dim rngNewColumnToStoreUnique As Range
Dim cel As Range
Set oDict = CreateObject("Scripting.Dictionary")
Set rngToScrub = Range(Me.RefEdit1.Value)
Set rngNewColumnToStoreUnique = Sheet2.Range("A1")
For Each cel In rngToScrub
If oDict.exists(cel.Value) Then
'Do Nothing for Now
Else
oDict.Add cel.Value, 0
rngNewColumnToStoreUnique.Value = cel.Value
Set rngNewColumnToStoreUnique = rngNewColumnToStoreUnique.Offset(1)
End If
Next cel
End Sub