I have some data in column A and am trying to write a macro to extend the data range to the next - column B, so that every time I add data in following columns, the macro will extend the border to include that data in the graph plot.
See image below where only column A is included in my graph -
What do I need to do in order to get it to also include the next column - column B
For example:
What do you think?
This works for me:
Sub ExpandChartSource()
Dim ObjChart As Object
Dim RngSource As Range
Set ObjChart = ActiveSheet.ChartObjects(1)
Set RngSource = Range(Split(ObjChart.Chart.SeriesCollection(1).Formula, ",")(2))
Set RngSource = RngSource.Resize(RngSource.Rows.Count, RngSource.Columns.Count + 1)
ObjChart.Chart.SetSourceData Source:=RngSource
End Sub
Here a more dynamic version, useful if you want to enlarge the data indefinitely:
Sub ExpandChartSource()
Dim ObjChart As Object
Dim RngSource As Range
Dim IntSeries As Integer
Dim StrAddress As String
Set ObjChart = ActiveSheet.ChartObjects(1)
Set RngSource = Range(Split(ObjChart.Chart.SeriesCollection(1).Formula, ",")(2))
StrAddress = RngSource.Cells(1, 1).Address
Set RngSource = Range(Split(ObjChart.Chart.SeriesCollection(ObjChart.Chart.SeriesCollection.Count).Formula, ",")(2))
StrAddress = StrAddress & ":" & RngSource.Cells(RngSource.Rows.Count, 1).Address
Set RngSource = Range(StrAddress)
Set RngSource = RngSource.Resize(RngSource.Rows.Count, RngSource.Columns.Count + 1)
ObjChart.Chart.SetSourceData Source:=RngSource
End Sub
It assumes that the first series is the one most on the left while the last series is assumed to be on the right.
Related
I would like to create a presentation based on data sorted in rows:
That, in the PowerPoint, would appear as this
But I am having difficulties understanding the correct syntax to properly have this done inside PowerPoint, rather than the Excel where the data comes from: how to declare/deal with the range of cells that become each a slide and in each of them of how to fill the relative placeholder, or "transposed/cut" place in table. I have looked everywhere, the very few pages/articles I found are not clear and overall short of explanation. I am stuck at the very beginning of this as I don't know how to set up the variable range of cells or if it should be an array to split later in different ranges, I would know how to continue, once I understood how to link Excel to PowerPoint Layouts/Slides/Objects.
I know I have to set a counter for each step, i.e. on for the change in Section #, in in the Slide # etc., mostly I find not clear how to translate the different parts of the table in rows and then section of rows.
EDIT: With code I have come up so far, this was the most helpful resource I could find. However I have the problem I was mentioning before: I do I swap the row I have left to columns in the table? How do I change them in a Range?
I referenced Excel for PowerPoint as from the original code, but the selection does no get recognized in POwerPoint (as said above, I would like to use it in PPT, not in Excel) . However, it works only in Excel, I have an error at For Each DataRow In DataRange.Rows variable not set when running as pptm. (reciprocal Libraries enabled in both programs).
From Excel, I can populate the title and the heading (so "AAA" and "aa") but I do not know how to progress in the cells, transposing the values for some columns and then restart.
Update:
I added a variable for the the columns of the source, but I am not sure how to deal with it. I'm so close but I don't know how to finish it. I introduced the variable FirstRowToColumn as range (columns E to the Excel screenshot below, that would become the first column of the tabel in PowerPoint), but I don't know how to declare this and the others range and paste them into the table. Could someone please teach me this or point to the solution, am I at least close ?
Edit2: added, with which I would copy the range and paste transposed, but it says the area is different.
Edit3: I can paste, I have to fix the counter to have the table in each slide, but the question of how to transpose remains and on top of that how to write the values in the Powerpoint table.
Edit 4:
I am trying a new way, by pasting in the Object placeholder id, but I saee nothing appearing in the table.
Sub General_Namer_For_Slides_And_Shapes()
Dim AnySlide As Slide
Dim AnyShape As Shape
Set AnySlide = Application.ActivePresentation.Slides(1)
For Each AnyShape In AnySlide.Shapes
Debug.Print "Application.ActivePresentation.Slides(1) AnySlide.Shapes AnyShape.Name " & AnyShape.Name & " AnyShape.Id "; AnyShape.Id '''names of each shape and their id '''removed " Slide " & AnySlide.SlideID&;
Next
Debug.Print "ActivePresentation.Slides(1).CustomLayout.Name " & ActivePresentation.Slides(1).CustomLayout.Name & " ActivePresentation.Slides(1).CustomLayout.Index " & ActivePresentation.Slides(1).CustomLayout.Index&;
Debug.Print " There are " & ActivePresentation.SlideMaster.Design.SlideMaster.CustomLayouts(4).Shapes.Count & " shapes in the Layout slide (SlideMaster View)"
'Debug.Print "ActivePresentation.Designs(4).Name = " & ActivePresentation.Designs(1).SlideMaster.CustomLayouts(4); ""
'Debug.Print " ActivePresentation.Designs.Name" & ActivePresentation.SlideMaster.Shapes.Placeholders. & ; ActivePresentation.Designs(4).Index; " & ActivePresentation.Designs(4).Index "
End Sub
Set NewTable = sld.Shapes.AddTable(12, 4)
FirstRowToColumn.Cells.PasteSpecial Paste:=-4163, Transpose:=True
to
Sub LoopRowsSelectedXCLToPPT()
Dim xlApp As Object
Dim xlWorkBook As Object
Dim xlSheet As Object
Dim DataRange As Range 'used
Dim DataRow As Range 'used
Dim DataCol As Range 'used
Dim PPTrng As Range ''cloning here the above to use in PowerPoint
Dim ShpRng As ShapeRange ''cloning here the data raw as range of shapes i could create later
Dim ShpCll As Shape
Dim AppPPT As PowerPoint.Application
Dim Pres As PowerPoint.Presentation
Dim sld As PowerPoint.Slide
Dim AppXCL As Excel.Application 'repeated the same as above with Excel as argument
Dim InputSheet As Excel.Worksheet
Set AppPPT = GetObject(, "PowerPoint.Application")
Set Pres = AppPPT.ActivePresentation
Set AppXCL = GetObject(, "Excel.Application")
Set InputSheet = AppXCL.ActiveSheet
Dim RowCounter As Integer
Dim ColCounter As Integer
Dim iRow As Integer
Dim iColumn As Integer
Dim FirstRowToColumn As Range
Dim SecondRowToColumn As Range
RowCounter = 0
ColCounter = 0
Set DataRange = Selection
For Each DataRow In DataRange.Rows
RowCounter = RowCounter + 1
Set sld = Pres.Slides.AddSlide(Pres.Slides.Count + 1, Pres.SlideMaster.CustomLayouts(4))
sld.Shapes.Title.TextFrame.TextRange.Text = DataRow.Cells(3, 3)
sld.Shapes.Placeholders(4).TextFrame.TextRange.Text = DataRow.Cells(3, 4)
' For Each DataCol In DataRange.Columns
ColCounter = ColCounter + 1
Set FirstRowToColumn = DataRange.Range(Cells(RowCounter + 1, 5), Cells(RowCounter + 1, 10))
FirstRowToColumn.Copy
Set NewTable = sld.Shapes.AddTable(12, 4)
sld.Shapes.Placeholders(4).TextFrame.TextRange.Text = FirstRowToColumn.Cells(1, 5)
' FirstRowToColumn.Cells(1, 10) =
' With sld.Shapes.Placeholders
' NewTable.Range(1,1)
'
'
' End With
' With sld.Shapes.Paste.SpecialPaste:=-4163, Transpose:=True
Next DataRow
Debug.Print RowCounter
Debug.Print ColCounter
End Sub
You may have to finesse the details but this works for me:
Sub LoopRowsSelectedXCLToPPT()
Const TABLE_COLS As Long = 5 '# of columns in PPT tables
Const BLOCK_SIZE As Long = 5
Dim Datarange As Range, rw As Range, rng As Range, i As Long, col As Long
Dim ppApp As PowerPoint.Application, pres As PowerPoint.Presentation
Dim sld As PowerPoint.Slide, newTable As PowerPoint.Table
On Error Resume Next
Set ppApp = GetObject(, "PowerPoint.Application")
Set pres = ppApp.ActivePresentation
On Error GoTo 0
If pres Is Nothing Then
MsgBox "Destination presentation must be open in PowerPoint", vbCritical
Exit Sub
End If
Set Datarange = Selection
For Each rw In Datarange.Rows
Set sld = pres.Slides.AddSlide(pres.Slides.Count + 1, _
pres.SlideMaster.CustomLayouts(2))
Set newTable = sld.Shapes.AddTable(BLOCK_SIZE, TABLE_COLS).Table
col = 0
Set rng = rw.Cells(5).Resize(1, BLOCK_SIZE) 'first BLOCK_SIZE cells starting from Col E
Do While Application.CountA(rng) > 0 'while have any data in `rng`
col = col + 1
If col > TABLE_COLS Then Exit Do 'ran out of columns in the PPT table...
For i = 1 To BLOCK_SIZE 'fill column # col
newTable.Cell(i, col).Shape.TextFrame2.TextRange.Text = rng.Cells(i).Value
Next i
Set rng = rng.Offset(0, BLOCK_SIZE) 'next block of cells to the right
Loop
Next rw
End Sub
I am attempting to populate columns D-J of table1, with the values in table2, columns B-H. The values should be based upon the value of column C in table1.
I have the code below, but I believe that is copying the tables as is and not doing a check of the value in column C.
Images:
Sub wps()
Dim rng As Range
Dim strTable As String
Dim strAddress As String
Dim i As Long
With Worksheets("Procedures")
For i = 1 To .ListObjects.Count
strTable = .ListObjects(i).Name
Set rng = .ListObjects(strTable).Range
strAddress = rng.Cells(2, 3).Address
rng.Copy Destination:=Worksheets("Base Data").Range(strAddress)
With Worksheets("Base Data")
.ListObjects(i).Name = "quals"
End With
Next i
End With
End Sub
It looks like a destination.value=source.value situation, using a single Match(). You could wrap this in a loop on your destWS.
Maybe something like (mock-up, untested):
For i = 2 to lastRowDest
dim sourceWS as worksheet
set sourceWS = sheets(1)
dim destWS as worksheet
set destWS = sheets(2)
destinationSearchTerm = destWS.Cells(i,"C").Value
dim sourceRow as long
sourceRow = Application.Match(destinationSearchTerm, sourceWS.Columns("A"), 0)
destWS.Range(destWS.Cells(i,"D"), destWS.Cells(i,"J") = sourceWS.Range(sourceWS.Cells(sourceRow,"B"),sourceWS.Cells(sourceRow,"H")
Next i
I am trying to figure out simple code to make picture objects visible if particular cells contain data. Cells in range R12:R61 contains objects (pictures, ie. Round Rectangles) that are not visible (.visible = false).
If some cells in range P12:P61 contains data then corresponding hidden image in range R12:R61 of that row need to be visible. I've tried something like this:
Dim xPicRg As Range
Dim xPic As Picture
Dim xRg As Range
Set xRg = Range("R12:R61")
For Each xPic In ActiveSheet.Pictures
Set xPicRg = Range(xPic.TopLeftCell.Address & ":" & xPic.BottomRightCell.Address)
If Not Intersect(xRg, xPicRg) Is Nothing Then xPic.Visible = True
Next
I'm stuck with this one.
Let's imagine our input looking like this:
Then, working with Range("A1:B10"), the only picture that should be present is the one in rows 1 and 2, as for the other 3 there are numbers in column "A":
Sub TestMe()
Dim checkRange As Range
Dim myPic As Picture
With ActiveSheet
Set checkRange = .Range("A1:B10")
Dim myRow As Range
For Each myRow In checkRange.Rows
If WorksheetFunction.Count(myRow.Cells) > 0 Then
For Each myPic In .Pictures
Debug.Print myPic.TopLeftCell.Address
Debug.Print myPic.BottomRightCell.Address
Dim picRange As Range
Set picRange = .Range(.Cells(myPic.TopLeftCell.Row, myPic.TopLeftCell.Column), _
.Cells(myPic.BottomRightCell.Row, myPic.BottomRightCell.Column))
Debug.Print picRange.Address
If Not Intersect(picRange, myRow) Is Nothing Then
myPic.Visible = False
End If
Next
End If
Next
End With
End Sub
I have items that are being populated on a worksheet via userform. When I open the workbook I'm trying to get the tool to go to the sheet grab the data and generate a chart/dashboard on the main landing sheet.
In the range of data contains statuses. I want VBA to look through one column of data and create a chart that counts each different status and put that in a bar chart.
yaxis = the different statuses
xaxis = count
my code so far
Sub populatecharts()
Dim ws As Worksheet
Dim ch As Chart
Dim tablerng As Range
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim sh As String
Set ws = ActiveSheet
'When the workbook opens it should always check the data and populate the BA Dashboard
'I need to check for sheets and if they exist generate a chart from the data
sh = "Action"
On Error Resume Next
Worksheets("Action").Visible = True
If CheckSheetExist(sh) = False Then
GoTo nextchart1
Else
Worksheets(sh).Activate
'Set ws = ActiveSheet
Set rng1 = Range("G4", Range("G4", "G4").End(xlDown))
rng1.Select
'Set rng2 = Range("B2")
'Set rng3 = Range("C3")
'Set tablerng = rng1 '& rng2 & rng3
Set ch = ws.Shapes.AddChart2(Width:=200, Height:=200, Left:=Range("B4").Left, Top:=Range("B4").Top).chart
With ch
.SetSourceData Source:=rng1
.ChartType = xlBarClustered
.ChartTitle.Text = "Action Items by Status"
End With
ws.Activate
Worksheets("Action").Visible = False
End If
Seems easy but I'm not able to think through it, also the location is hit or miss even though I define the top and bottom and size. Sometimes it's to the right of the cell I chose to be the left.
Try the next way, please. It uses a dictionary to extract the unique values and their count and array to feed the necessary series. Try running it on active sheet and adapt it to your situation only after having the confirmation that what it returns is what you need:
Sub populatecharts()
Dim shT As Worksheet, ch As Chart, lastRow As Long
Dim arrY, arrX, i As Long, dict As Object
Set shT = ActiveSheet 'use here the sheet you need
lastRow = shT.Range("G" & shT.Rows.count).End(xlUp).row
arrX = shT.Range("G4:G" & lastRow).Value 'put the range in a array
Set dict = CreateObject("Scripting.Dictionary") 'needed for the next step
On Error Resume Next
shT.ChartObjects("MyChartXY").Delete 'for the case of re running need
On Error GoTo 0
For i = 1 To UBound(arrX)
If Not dict.Exists(arrX(i, 1)) Then
dict(arrX(i, 1)) = 1 'create the unique keys
Else
dict(arrX(i, 1)) = dict(arrX(i, 1)) + 1 'increment the key next occurrrence
End If
Next i
arrX = dict.Keys: arrY = dict.Items 'extract the necessary arrays
Set ch = shT.ChartObjects.Add(left:=shT.Range("B4").left, _
top:=shT.Range("B4").top, width:=200, height:=200).Chart
With ch
.ChartType = xlBarClustered
.HasTitle = True
.ChartTitle.Text = "Action Items by Status"
.SeriesCollection.NewSeries.Values = arrY 'feed it with the array elements
.SeriesCollection(1).XValues = arrX 'feed it with the array elements
End With
End Sub
Please, test it and send some feedback.
Newbie question: I have module, originally made by Roger Govier.
It uses an input cell header and creates a dynamic named range for the non empty cells positioned under header. The created named range will be labeled as the value of the header cell.
Private Sub CreateNamedRange(header As range)
Dim wb As Workbook
Dim WS As Worksheet
Dim rStartCell As range
Dim rData As range
Dim rCol As range
Dim lCol As Long
Dim sSheet As String
Dim Rowno As Long
' get table location
Set rStartCell = header
Set WS = rStartCell.Worksheet
Set wb = WS.Parent
sSheet = "'" & WS.Name & "'"
With rStartCell
Rowno = .row
Set rData = .CurrentRegion
End With
Set rData = WS.range(rStartCell, WS.Cells(Rowno, rStartCell.Column))
Set rCol = rData.Columns
lCol = rCol.Column
wb.Names.Add Name:=Replace(rCol.Cells(1).Value, " ", "_"), _
RefersToR1C1:="=" & sSheet & "!" & rCol.Cells(2).Address(ReferenceStyle:=xlR1C1) & ":INDEX(C" & lCol & ",LOOKUP(2,1/(C" & lCol & "<>""""),ROW(C" & lCol & ")))"
End Sub
I want to modify this code so that instead of creating a named range it only returns the returns the range of the what would have been the named range.
Example:
We have a header in A1, and data in A2:A5.
Now: If we call CreateNamedRange(.range("A1")), it creates a dynamic named range for A2:A5.
Goal: If we call CreateNamedRange(.range("A1")) it returns .range("A2:A5") to a variable in the VBA code:
dim myRange As Range
set myRange = CreateNamedRange(.range("A1"))
First thing you should note is that Subs do not return any value and thus myRange = CreateNamedRange(.range("A1")) does not make any sense (with your Sub; it does make sense with the Function in this answer).
The function below returns a range, in the same column that the input range, starting from the next row and including all the ones below until finding a blank cell. This range is called "anyName" (and thus you can access it via Range("anyName")).
Private Function CreateNamedRange(header As Range) As Range
Dim curRow As Long: curRow = header.Row + 1
Set tempRange = header.Worksheet.Cells(curRow, header.Column)
Do While (Not IsEmpty(tempRange))
curRow = curRow + 1
Set tempRange = header.Worksheet.Cells(curRow, header.Column)
Loop
Set CreateNamedRange = header.Worksheet.Range(header.Worksheet.Cells(header.Row + 1, header.Column), header.Worksheet.Cells(curRow, header.Column))
CreateNamedRange.Name = "anyName"
End Function
If you already have the beginning cell activated you can just use
Set myRange = Range(ActiveCell.Address, ActiveCell.Offset.End(xlDown).Address)
to set your range for all entries below the active cell. If you don't have it activated, you can just use your rstartCell reference with an offset
Set myRange = Range(rStartCell.Offset(1), rStartCell.Offset(1).Offset.End(xlDown).Address)
Then you can just add the named range in the next line