I'd like to create a macro that counts the number of charts within a given range, then performs certain actions depending on the number counted. I know activesheet.chartobjects.count would count across the whole sheet, how would I modify to count within a range?
Here's the skeleton of my code.
Sub chrt_chck()
Dim rng As Range
Dim x As Long
Set rng = Range("A1:F10")
x = ActiveSheet.rng.ChartObjects.Count
If x > 1 Then
'select and delete all charts in range
End If
If x = 1 Then
'select that chart and update format
Else
'create chart and set format
End If
End Sub
Please, try the next way:
Sub chrt_chck()
Dim rng As Range, chO As ChartObject, x As Long, arrChO() As ChartObject, k As Long, El
Set rng = Range("B2:D15") ' Range("A1:F10")
ReDim arrChO(ActiveSheet.ChartObjects.count - 1)
For Each chO In ActiveSheet.ChartObjects
If Not Intersect(chO.TopLeftCell, rng) Is Nothing Then
x = x + 1
Set arrChO(k) = chO: k = k + 1
End If
Next
If x > 1 Then
'select and delete all charts in range
For Each El In arrChO
Debug.Print El.name
El.Delete
Next
End If
If x = 1 Then
'select that chart and update format
With arrChO(0)
.Select
Debug.Print .name
'do wahtever needed with the chart...
End With
Else
'create chart and set format
End If
End Sub
It counts all chart objects having their Top Left corner inside the rng Range.
Related
The following macro lists all the chart numbers of by worksheet but it order them and this is not how the charts appear in the sheet.
Sub ListChartNames()
Dim Cht As ChartObject
Dim i As Integer
i = 1
For Each Cht In ActiveSheet.ChartObjects
Cells(i, 1) = Cht.Chart.Name
i = i + 1
Next Cht
End Sub
For example, I have a chart in E6:L17 (let's call this one Chart 1) and another in N6:U17 (let's call this one Chart 11).
Then, I move down to two charts in E19:L30 (let's call this one Chart 400) and another in N19:U30 (let's call this one Chart 2).
Then, I move down to two charts in E32:L43 (let's call this one Chart 3) and another in N32:U43 (let's call this one Chart 12)
Then, I move down to only 1 chart in E45:L56 (let's call this one Chart 13)
Then, I back to two charts in E58:L69 and another in N58:U69 (let's call these Chart 15 and Chart 16)
and so on.....
The above charts are all in columns E through U. But then there is another set in columns Y through AO in same patter and again in AS through BI, etc.
I have like 500 charts and I'd like a macro to list them starting in the first set of columns (E through L) but list them from top to bottom, let to right.
So, the results based on the above would be for columns F through U
Chart 1
Chart 11
Chart 400
Chart 2
Chart 3
Chart 12
Chart 13
Chart 15
Chart 16
The macro above lists the charts in a sorted order which is not what I need.
This also doesn't answer the question: Select chart object based on position in sheet (VBA)
Does this give you what you need?
Sub list_charts_in_top_left_to_bottom_right()
Dim ws As Worksheet, outputsh As Worksheet, last_cell As Range, oChartObj As Object
Set ws = ThisWorkbook.Sheets("SheetWithChartsOnIt")
Set outputsh = ThisWorkbook.Sheets("SheetToWriteTo")
outputsh.Range("A:A").ClearContents
outputsh.Range("A1") = "Output:"
If ws.ChartObjects.Count = 0 Then
outputsh.Range("A2") = "No charts found"
Exit Sub
End If
Debug.Print "Charts found: " & ws.ChartObjects.Count
Set last_cell = ws.Range("A1")
'find bounds of range by expanding last_cell with each chart
For Each oChartObj In ws.ChartObjects
With oChartObj
If .TopLeftCell.Row > last_cell.Row Then Set last_cell = ws.Cells(.TopLeftCell.Row, last_cell.Column)
If .TopLeftCell.Column > last_cell.Column Then Set last_cell = ws.Cells(last_cell.Row, .TopLeftCell.Column)
End With
Next
Debug.Print "Bounds of range: $A$1:" & last_cell.Address
Dim area_to_examine As Range
For col = 5 To last_cell.Column Step 21 'start with column 5 (E) and then jump 21 columns at a time
Set area_to_examine = Range(Columns(col), Columns(col + 17))
Debug.Print "Examining: " & area_to_examine.Address
For Each rw In Intersect(area_to_examine, ws.Range("A1", last_cell.Address).Rows)
For Each cl In rw.Cells
For Each oChartObj In ws.ChartObjects
With oChartObj
If .TopLeftCell.Row = cl.Row And .TopLeftCell.Column = cl.Column Then
outputsh.Cells(outputsh.Rows.Count, "A").End(xlUp).Offset(1) = .Name
Debug.Print .Name
End If
End With
Next
Next
Next
Next
End Sub
This is an alternative method. It's still not using a sort algo, but uses a workaround which (does waste a little time but) should be massively quicker than scanning every cell in the sheet:
Sub list_charts_in_top_left_to_bottom_right_v2()
Dim ws As Worksheet, outputsh As Worksheet, chartCount As Long, x As Long, y As Long, maxZ As Long
Set ws = ThisWorkbook.Sheets("SheetWithChartsOnIt")
Set outputsh = ThisWorkbook.Sheets("SheetToWriteTo")
outputsh.Range("A:A").ClearContents
outputsh.Range("A1").Value = "Chart"
chartCount = ws.ChartObjects.Count
ReDim arrChartlist(chartCount, 1)
If chartCount = 0 Then
outputsh.Range("A2") = "No charts found"
Exit Sub
End If
maxZ = 0
For x = 0 To chartCount - 1
With ws.ChartObjects(x + 1)
arrChartlist(x, 0) = .Name
arrChartlist(x, 1) = (((.TopLeftCell.Column - 2) \ 19) * chartCount * chartCount) + (.TopLeftCell.Column * chartCount) + .TopLeftCell.Row
If maxZ < arrChartlist(x, 1) Then maxZ = arrChartlist(x, 1)
End With
Next
For x = 0 To maxZ
For y = 0 To chartCount - 1
If x = arrChartlist(y, 1) Then
outputsh.Cells(outputsh.Rows.Count, "A").End(xlUp).Offset(1).Value = arrChartlist(y, 0)
End If
Next
Next
End Sub
I want to write a macro to copy rows from one worksheet to another below cell that is colored black (manually) - if it is detected, otherwise just copy rows from first sheet to Sheet1 at the top. After many trials and errors I came up with that code:
Sub copytherows(clf As Long, lastcell As Long) 'clf - cell that marks the start, lastcell - ending cell
Dim st As Long, cnext As Range
Dim wshet As Worksheet
Dim wshetend As Worksheet
'st - start of looking up, cnext - range of lines, wshet - worksheet
Dim coprange As String
Dim cnextcoprow, cnextrow As Long
'variables for copying macro part
Dim rangehelper As Range
Dim TargetColor As Long
Dim cell As Range
Dim sht As Worksheet
Dim x As Long
Dim Aend As Long
Set wshet = Worksheets(1)
Set wshetend = Sheets("Sheet1")
wshetend.Cells.Delete
For st = 1 To wshet.Cells(Rows.Count, "B").End(xlUp).Row
If wshet.Cells(st, "B").Interior.Color = clf Then 'has the color of interest
cnextcoprow = st
Set cnext = wshet.Cells(st, "B").Offset(1, 0) 'next cell down
Do While cnext.Interior.Color <> lastcell
Set cnext = cnext.Offset(1, 0) 'next row
Loop
st = st + 1
End If
Next st
cnextrow = cnext.Row - 1
coprange = cnextcoprow & ":" & cnextrow
Aend = Cells(Rows.Count, "A").End(xlUp).Row
'set color is black
TargetColor = RGB(255, 255, 255)
wshetend.Activate
For x = 1 To Rows.Count
If wshetend.Cells(x, "A").Interior.Color = TargetColor Then
x = x + 1
Set rangehelper = wshetend.Rows(x)
wshet.Range(coprange).Copy wshetend.Range(rangehelper).Offset(1)
Else
wshet.Range(coprange).Copy wshetend.Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next x
End Sub
When Macro is ran it displays an error(Run-time error '1004' Method 'Range' of object '_Worksheet' failed on line :
wshet.Range(coprange).Copy wshetend.Range(rangehelper).Offset(1)
Sheet1 is for sure present in Workbook.
Edit as suggested by #FaneDuru:
1 - in this image is my curret state of worksheet that is wshet in my macro and for example if I select (by checkboxes) section1 and section3, section3 should be in the place of black cell in section1 (the order of sections doesn't really matter to me) inside destination sheet ( I know I'm not good in explaining things like that).
2 - this should be end result of this macro
It's quite confusing how you use the for loops.
In the first one you use it to check for the start -which is fine- but then you put a while loop in there which will end up in an endless loop once your st gets past your lastcell row, instead use
ElseIf wshet.Cells(st, "B").Interior.Color = lastcell Then
cnextrow = st
Exit For
End If
In the second for loop you copy the rows if you find the black cell but you don't exit the for loop, speaking of which, you delete all the cells in your wshetend so you'll always start at row 1. So either you don't want to delete all the cells in your wshetend or the for loop is unnecessary.
This is my testSub and it copies from the first sheet to Sheet2 after the cell with black background (black = 0) (commented out the delete cells)
Sub TestBlackCellCopy()
Dim st As Long, cnext As Range
Dim wshet As Worksheet
Dim wshetend As Worksheet
'st - start of looking up, cnext - range of lines, wshet - worksheet
Dim coprange As String
Dim cnextcoprow, cnextrow As Long
'variables for copying macro part
Dim rangehelper As Range
Dim TargetColor As Long
Dim cell As Range
Dim sht As Worksheet
Dim x As Long
Dim Aend As Long
Dim clf As Long, lastcell As Long
clf = 5296274
lastcell = 65535
cnextcoprow = 0
Set wshet = Worksheets(1)
Set wshetend = Sheets("Sheet1")
' wshetend.Cells.Delete
For st = 1 To wshet.Cells(Rows.Count, "B").End(xlUp).Row
Debug.Print (wshet.Cells(st, "B").Interior.Color)
If wshet.Cells(st, "B").Interior.Color = clf And cnextcoprow = 0 Then 'has the color of interest
cnextcoprow = st
ElseIf wshet.Cells(st, "B").Interior.Color = lastcell Then
cnextrow = st - 1
Exit For
End If
Next st
coprange = cnextcoprow & ":" & cnextrow
Aend = Cells(Rows.Count, "A").End(xlUp).Row 'unused variable?
'set color is black
TargetColor = 0
wshetend.Activate
For x = 1 To Rows.Count
Debug.Print (wshetend.Cells(x, "A").Interior.Color)
If wshetend.Cells(x, "A").Interior.Color = TargetColor Then
wshet.Rows(coprange).EntireRow.Copy wshetend.Range("A" & x).Offset(1)
Exit For
' Else
' wshet.Range(coprange).Copy wshetend.Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next x
End Sub
So you'll have to figure out what exactly you want, to delete the cells? Then it starts at row 1, then put a skip after a copy you place after the second for loop.
Something like this:
wshetend.Activate
Aend = Cells(Rows.Count, "A").End(xlUp).Row
For x = 1 To Rows.Count
Debug.Print (wshetend.Cells(x, "A").Interior.Color)
If wshetend.Cells(x, "A").Interior.Color = TargetColor Then
wshet.Rows(coprange).EntireRow.Copy wshetend.Range("A" & x).Offset(1)
GoTo skipFor
End If
Next x
wshet.Rows(coprange).EntireRow.Copy wshetend.Range("A1")
skipFor:
Hope this helps.
Please, try the next way. It should work if you respected all what we set in the above discussion (check boxes in G:G, black cells in B:B for first sheet, and a black cell in any place of the second sheet:
Sub CopyRowsCheckBox_Black_limited()
Dim wshet As Worksheet, wshetend As Worksheet, blackCell As Range, redCell As Range, rngCopy As Range
Dim sh As Shape, chkB As MSForms.CheckBox, cellPaste As Range, pasteRow As Long
Set wshet = ActiveSheet 'use here the sheet where from you need copying
Set wshetend = wshet.Next 'use here the sheet where to copy
'settings to make Find function searching for Interior color:
With Application.FindFormat
.Clear: .Interior.Color = vbBlack
.Locked = True
End With
'find the black cell in the second sheet:
Set cellPaste = wshetend.cells.Find(What:=vbNullString, After:=wshetend.Range("A1"), SearchFormat:=True)
If Not cellPaste Is Nothing Then 'set the row where to copy first
pasteRow = cellPaste.Offset(1).row
Else
pasteRow = 1
End If
'iterate between all shapes, found the ones being checkBoxes and being on column G:G, set the rows range and copy it:
For Each sh In wshet.Shapes
If TypeName(sh.OLEFormat.Object.Object) = "CheckBox" And sh.TopLeftCell.Column = 7 Then
Set chkB = sh.OLEFormat.Object.Object 'set the checkBox ActiveX object
If chkB.Value = True Then 'if it is checked
Set blackCell = wshet.Range("B:B").Find(What:=vbNullString, After:=wshet.Range("B" & _
sh.TopLeftCell.row), SearchFormat:=True) 'find first black cell
Set rngCopy = wshet.Range(wshet.Range("B" & sh.TopLeftCell.row), blackCell).EntireRow 'set the rows to be copied
rngCopy.Copy wshetend.Range("A" & pasteRow): pasteRow = pasteRow + rngCopy.rows.count 'copy and update pasting row
End If
End If
Next sh
MsgBox "Ready..."
End Sub
The range to be copied is the one between the checked check box and the first black cell in B:B column.
Important Note: The top left corner of the check boxes must be inside of first series row!
Please, send some feedback after testing it.
I need to select the demand range in sheet 1 corresponding to the part number selected in Sheet 2 of my workbook. So far, I have written the macro to automatically select the part number in sheet 1 when the same part number is selected in sheet no 2. But, I'm having trouble selecting the range corresponding to the part number, which I want to base my calculations on. Can anyone please tell me how to select the range?
Public Sub calculation()
Dim x As Variant
Dim rng As Range
Dim i As Variant
Dim j As Integer
Dim findcell As Range
Dim a_1 As Range
Dim b_1 As Range
Dim rnge As Range
Worksheets("Sheet2").Activate
x = Worksheets("Sheet2").Range("C3").Value
Worksheets("Sheet1").Activate
Set rng = Worksheets("Sheet1").Range("A2:A26")
For Each i In rng
If x = i Then
Set findcell = i
End If
Next i
j = findcell.Select
Set a_1 = ActiveCell.Offset(0, 1)
Set b_1 = ActiveCell.Offset(0, 66)
Worksheets("Sheet2").Range("C9").Value "=AVERAGE(Sheet1!"a_1.Address":"b_1.Address")"
End Sub
Should be able to do something like this:
Public Sub calculation()
Dim f As Range
Set f = Worksheets("Sheet1").Range("A2:A26").Find( _
what:=Worksheets("Sheet2").Range("C3").Value, _
lookat:=xlWhole)
With Worksheets("Sheet2").Range("C9")
If Not f Is Nothing Then
.Formula = "=AVERAGE(Sheet1!" & f.Offset(0, 1).Resize(1, 66).Address & ")"
Else
.Value = "???"
End If
End With
End Sub
I'm trying to get all my filtered data in one range variable but it doesn't work.
When the visible datas are continuous (rows 25 to 200), i've no problem but when the visible datas are discontinuous (rows 25 to 27, then 43 to 47, then 60 to 92) it only get the first range (rows 25 to 27)
Here is my code :
datas = dataSheet.Range("A2:L" & dataSheet.
[A65000].End(xlUp).Row).SpecialCells(xlCellTypeVisible).Value
Do you have any tip ?
Thank you for your answer.
Louis
It sounds like you're trying to populate an array variable named datas, which is successful if your range is continuous, but only gets the first section when discontinuous. And what you're looking for is to populate the array with all of the data from the discontinuous range.
That is possible, and there are two approaches. The first is to copy the discontinuous range and paste it into a temp worksheet. The pasted range will be continuous and then you can load it into the array normally as shown in your original code. The second is to populate the array directly, but you'll have to loop through each visible cell to do this.
Method 1 (use temp worksheet):
Sub tgrTempWS()
Dim dataSheet As Worksheet
Dim tempSheet As Worksheet
Dim rData As Range
Dim datas As Variant
Set dataSheet = ActiveWorkbook.Sheets("Sheet1")
On Error Resume Next
Set rData = dataSheet.Range("A2:L" & dataSheet.[A65000].End(xlUp).Row).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rData Is Nothing Then Exit Sub 'No data
Set tempSheet = dataSheet.Parent.Sheets.Add
rData.Copy tempSheet.Range("A1")
datas = tempSheet.Range("A1").CurrentRegion.Value
Application.DisplayAlerts = False
tempSheet.Delete
Application.DisplayAlerts = True
'do stuff with your datas array variable here
End Sub
Method 2 (loop through visible cells):
Sub tgrLoop()
Dim dataSheet As Worksheet
Dim rData As Range
Dim rCell As Range
Dim datas As Variant
Dim lRow As Long, lCol As Long
Dim i As Long, j As Long
Set dataSheet = ActiveWorkbook.Sheets("Sheet1")
On Error Resume Next
Set rData = dataSheet.Range("A2:L" & dataSheet.[A65000].End(xlUp).Row).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rData Is Nothing Then Exit Sub 'No data
ReDim datas(1 To Intersect(rData, rData.Areas(1).Resize(, 1).EntireColumn).Cells.Count, 1 To rData.Columns.Count)
For Each rCell In rData.Cells
If lRow = 0 Then
lRow = rCell.Row
i = 1
ElseIf rCell.Row > lRow Then
i = i + 1
lRow = rCell.Row
End If
If lCol = 0 Or rCell.Column < lCol Then
lCol = rCell.Column
j = 1
ElseIf rCell.Column > lCol Then
j = j + 1
lCol = rCell.Column
End If
datas(i, j) = rCell.Value
Next rCell
'do stuff with your datas array variable here
End Sub
From MSDN about Range Object : "Represents a cell, a row, a column, a selection of cells containing one or more contiguous blocks of cells, or a 3-D range."
That's why you only get the first range. Have a look at this page to refer to multiple ranges.
An over-simplified description of my problem is illustrated in the figures below. I want to transform sparse data from a column in the Page1 worksheet to dense and then load it in a dense range in the Page2 worksheet.
My solution so far is that in the following code snippet. I would like to know if there is a more efficient alternative to achieve this goal, namely without a for loop or at least without the j variable.
Sub CopyFromMultipleRanges()
With Worksheets("Page1")
.Range("A1:A5").Value = 1
.Range("A8:A10").Value = 2
Dim c_cell As Range
Dim j As Long
j = 1
For Each c_cell In .Range("A1:A5,A8:A10")
Worksheets("Page2").Range("A" & j).Value = c_cell.Value
j = j + 1
Next
End With
Worksheets("Page2").Activate
End Sub
Initial column where data is sparse.
Final dense data column.
You can do this if you want to remove the blanks on the same sheet. If not just copy the data to a new sheet and then run this on that range
Sub Delete_Blank_Rows()
On Error Resume Next
Range("A1:A10").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Here's how I would do it:
'create a collection to store the data
Dim bin As New Collection
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim size As Long
Dim i As Long
Dim v As Variant
'set worksheet references
Set ws1 = Excel.Application.ThisWorkbook.Worksheets("Page1")
Set ws2 = Excel.Application.ThisWorkbook.Worksheets("Page2")
With ws1
size = .UsedRange.Rows.Count
'loop through the range to pick up the data from non-empty cells
For i = 1 To size
'if the cell is not empty, then add the value to the collection
If Not IsEmpty(.Cells(i, 1).Value) Then
bin.Add .Cells(i, 1).Value
End If
Next
'loop through the bin contents
i = 1
For Each v In bin
ws2.Cells(i, 1).Value = v
i = i + 1
Next
End With
Hope it helps!
Update:
I tested this code and it works:
Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Excel.Application.ThisWorkbook.Worksheets(1)
Set ws2 = Excel.Application.ThisWorkbook.Worksheets(2)
ws1.Range("A:A").SpecialCells(xlCellTypeConstants).Copy ws2.Range("A:A")
End Sub
you can read more about Range.SpecialCells here. learn something new everyday!
This assumes that you are considering the all rows with the lower and upper row limits of the ranges given ie. that "A1:A5" and "A8:A10" is indeed "A1:A10".
Option Explicit
Public Sub CopyFromMultipleRanges()
Dim rng As Range: Set rng = ThisWorkbook.Worksheets("Page1").Range("A1:A10")
Application.ScreenUpdating = False
If Application.WorksheetFunction.CountBlank(rng) = rng.Count Then Exit Sub
With rng
.AutoFilter
.AutoFilter 1, "<>"
.SpecialCells(xlCellTypeVisible).Copy Worksheets("Page2").Range("A1")
.AutoFilter
Application.ScreenUpdating = True
End With
End Sub