I have an excel workbook with the julian day in column one, the normal high temperature in column two, and the normal low temperature in column three. I need to write a script in PowerPoint VBA to match the current Julian Day with the same number in Column one in the workbook. Then I need it to extract the normal high for that day (Column two) and insert that number into a named shape in a particular PPT slide. Here is what I have so far:
Function SectionIndexOf(sSectionName As String) As Long
'This Function makes sure you can declare the name of any Section Name
'in the Sub below.
Dim x As Long
With ActivePresentation.SectionProperties
For x = 1 To .Count
If .Name(x) = sSectionName Then
SectionIndexOf = x
End If
Next
End With
End Function
Sub Climo()
Headlines = SectionIndexOf("Headlines")
'Open the Excel Workbook.
Dim CLI As New Excel.Workbook
Set CLI = Excel.Application.Workbooks.Open("Z:\climo.xlsx")
'Grab the first Worksheet in the Workbook
Dim WS As Excel.Worksheet
Dim NormalHi As String
Dim NormalLo As String
Dim shp As Shape
Dim sld As Slide
Set WS = CLI.Worksheets(1)
Dim i As Long
'Loop through all rows in Column A (Julian Day)
For i = 1 To WS.Range("A372").End(xlUp).Row
NormalHi = WS.Cells(i, 9).Value
Debug.Print NormalHi 'This just returns new blank lines
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If sld.sectionIndex = Headlines Then
With sld.Shapes("NormalHi")
.TextFrame2.TextRange.Font.Name = Arial
.TextFrame2.TextRange.Font.Size = 16
.TextFrame.TextRange.Font.Color = vbRed
.TextFrame2.TextRange.Text = NormalHi
End With
End If
Next
Next
Next
End Sub
Before even trying to figure out how to match the current Julian Day with the proper row in the Excel workbook, I am just trying to extract data from any cell and plot it in the shape. I get no errors when I run this and using Debug.Print gives me blank new lines. Not sure what is wrong. Thanks!
You mention in your question that the Normal High data is found in column 2 but then when you are grabbing the value, you're referencing column 9. Perhaps that's the issue?
NormalHi = WS.Cells(i, 9).Value
Related
This is my first real attempt to create something in VBA, so be gentle please.
This is what I need my program to do:
Run from PPT and open an Excel file
Start at slide 1 and find a box that contains the words "iq_", if it
has those words then it will have numbers after it like so "iq_43"
or "iq_43, iq_56, iq_72".
find those words and numbers in the opened Excel file. Needs to
recognize that ", " means there is another entry.
Copy column containing words from ppt ie. "iq_43"
Paste a Table into ppt with those values
Do this for every slide
I'm having issues with my function at the bottom. This is where the program should be shifting to work in the opened excel file. The idea there is to go through the headers of each column and search for values that I have stored in "iq_Array". Once values are found, then copy rows below it into another array called "tble" (which will eventually be pasted onto the powerpoint slide as a table).
The code currently stops at
rng = Worksheets("Sheet1").Cells(1, i).Value
I'm not sure what I'm doing wrong here. Once fixed, will this is be able to be copied into an array?
Another part I believe I'm having trouble with is how to return the function values. I currently have
xlFindText(iq_Array, xlWB) = tble()
At the bottom of my function in order to call it as such in my main code. Is this the proper way to do it?
Public Sub averageScoreRelay()
'Create variables
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim pptSlide As Slide
Dim fileName As String
Dim Shpe As Shape
Dim pptText As String
Dim strArray As String
Dim pptPres As Object
Dim PowerPointApp As Object
Dim iq_Array
' Create new excel instance and open relevant workbook
Set xlApp = New Excel.Application
xlApp.Visible = True 'Make Excel visible
Set xlWB = xlApp.Workbooks.Open("C:\Users\pinlop\Desktop\Gate\Macro\averageScores\pptxlpratice\dummyavgscore.xlsx", True, False) 'Open relevant workbook
If xlWB Is Nothing Then ' may not need this if statement. check later.
MsgBox ("Error retrieving Average Score Report, Check file path")
Exit Sub
End If
'Is PowerPoint already opened?
'Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Make PPT visible
Set pptPres = PowerPoint.ActivePresentation
Set pptSlide = Application.ActiveWindow.View.Slide 'Set pptSlide = pptPres.Slides _
(PowerPointApp.ActiveWindow.Selection.SlideRange.SlideIndex) (different way of saying the same thing?)
'Loop through each pptSlide and check for IQ text box, grab avgScore values and create pptTable
For Each pptSlide In pptPres.Slides
'searches through shapes in the slide
For Each Shpe In pptSlide.Shapes
'Identify if there is text frame
If Shpe.HasTextFrame Then
'Identify if there's text in text frame
If Shpe.TextFrame.HasText Then
pptText = Shpe.TextFrame.TextRange
If InStr(1, pptText, "iq_") > 0 Then 'Identify if within text there is "iq_" All IQ's have to be formatted like this "iq_42, iq_43" for now
iq_Array = Split(pptText, ", ") 'Use function below to Set iq_Array to an array of all iq_'s in the text box
xlFindText(iq_Array, xlWB).Copy
pptSlide.Shapes.PasteSpecial DataType:=ppPasteHTML, Link:=msoFalse ' Paste the Array
End If
End If
End If
Next Shpe
Next pptSlide
End Sub
Function xlFindText(iq_Array, xlWB) 'This function works in excel and saves the column values into xlFindText(iq_Array, xlWB) to be pasted as a table into ppt
'SetsxlTextID = to the array of iq_'s
Dim i As Integer
Dim k As Integer
Dim activeWB As Excel.Workbook
Dim size As String
Dim rng As Range
Dim tble As Range
'for loop to go through values stored in array
size = UBound(iq_Array) - LBound(iq_Array)
For i = 0 To size 'loops through array values
For k = 1 To 200 'loops through cloumns
rng = Worksheets("Sheet1").Cells(1, i).Value
If rng = iq_Array(i) Then 'matches column value to iq_Array
Columns(k).Select
tble(i) = Selection.Copy 'saves a copy of the range into tble() array
End If
Next k
Next i
xlFindText(iq_Array, xlWB) = tble()
End Function
There are several problems with your code, I'll go from start to end, but it may well be I'm missing some.
(1)
Set pptSlide = Application.ActiveWindow.View.Slide
is pointless because directly afterwards you overwrite pptSlide with:
For Each pptSlide In pptPres.Slides
xlFindText
(2)
rng = Worksheets("Sheet1").Cells(1, i).Value
If you work with a different Office program than the one where the code runs in (here Excel from PPT), you always must fully qualify your objects. Don't use shortcuts like ActiveSheet without specifying the parent object (Excel application).
So this should be:
xlWB.Worksheets("Sheet1").Cells(1, i).Value
The same applies to Columns(k).
(3)
rng is a Range object. This doesn't go together with a cell value.
Either
Set rng = xlWB.Worksheets("Sheet1").Cells(1, i)
or
Dim varValue As Variant
varValue = xlWB.Worksheets("Sheet1").Cells(1, i).Value
(4)
tble(i) = Selection.Copy
This is not how Range.Copy works, please check the Excel Online Help.
You will have to change the logic of xlFindText - either return a column number from this function and do the Copy + Paste in the main function, or do both in xlFindText (then pass pptSlide as parameter).
I am interning with a large firm that stores a lot of its source data in the form of PowerPoints. These PowerPpoints serve well when communicating across departments and between suppliers but, as you may guess, lack any robust analysis. Because of this, I have decided to database these Powerpoints into Access.
There is no direct way of doing this, that I know of. Due to strict IT policies, I am limited to VBA as my coding platform. I have spent the last week coding up a macro to solve my problem. Again, since there is no direct conversion of PowerPoint to Access, I have had to solve this problem rather inefficiently as there are a few caveats. I will list my steps and caveats below.
The powerpoint information I want to database is formatted as a table instead of text. I have been unable to find a Macro that converts PPT tables directly to Excel or CSV files. Because of this, I will convert all PPT files (roughly 3000) to PDFs.
From these generated PDF's I can use Adobe to convert them to Excel or CSV files.
Using multiple online resources and a bit of my own experience, I have coded up a VBA script that will automatically format a folder of CSV files into a format that Access will store correctly. See Code 1.
(The "Personal.xlsb!Module1.FormatAccess" is a macro created mostly with "Record Macro." I omitted this code due to its length and redundancy.)
After formatting the CSVs, I will then automate them all to Access.
Following the Access automation, I will need to embed each PPT file to its respective Access entry
Again, this is not an efficient process. Because I am limited to Microsoft only applications, I have chosen this route. I thought about leaving the information as Excel files, but the idea is to make this data accessible and searchable by any department, hence why I chose Access to database them.
Now that I have explained to you where I am coming from and what I am doing, I ask: what recommendations do you have for me? I feel my round-about way is a good solution and practical, but I wonder if there is a better solution.
Code 1
Sub LoopCSVFile()
Dim fso As Object 'Scritping.FileSystemObject
Dim fldr As Object 'Scripting.Folder
Dim file As Object 'Scripting.File
Dim wb As Workbook
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldr = fso.GetFolder("C:\Users\HMM105289\Documents\Powerpoint Parsing\Test Folder\Test Save Folder")
For Each file In fldr.Files
Set wb = Workbooks.Open(file.Path)
Application.Run "Personal.xlsb!Module1.FormatAccess"
wb.Close SaveChanges = True
Next
Set file = Nothing
Set fldr = Nothing
Set fso = Nothing
End Sub
Edit 1
Having played around with some of Tim's suggestions, I have come up with this code to run a check on each PPT slide. The idea is to have it run his "ExtractTable" macro inside. As it stands, I am unable to get it to execute.
Sub PPTableXtraction()
Dim oSlide As Slide
Dim oSlides As Slides
Dim oPPT As Object: Set oPPT = ActivePresentation
Dim oShapes As Shape
Dim oTable As Object
For Each oSlide In oPPT.Slides
For Each oShapes In oSlide.Shapes
If oShapes.HasTable Then
Application.Run "VBAProject.xlsb!Module3.ExtractTableContent"
End If
Next
Next
End Sub
Edit 2
I was able to build on Tim's code to create a code that loops each PowerPoint file and extracts the information into Excel. The code doesn't break into the debugger but for whatever reason it is not performing any functions. Would anyone have any idea why?
Sub Tester()
Dim ppts As PowerPoint.Application
Dim FolderPath As String
Dim FileName As String
FolderPath = "FolderPath"
FileName = Dir(FolderPath & "*.ppt*")
Do While FileName <> ""
Set ppts = New PowerPoint.Application
ppts.Visible = True
ppts.Presentations.Open FileName:=FolderPath & FileName
A = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 5
B = "B" & A
X = "A" & A
Range(X).Value = "New"
Dim ppt As Object, tbl As Object
Dim slide As Object, pres As Object, shp
Dim rngDest As Range
Set ppt = GetObject(, "Powerpoint.Application")
Set pres = ppt.ActivePresentation
Set rngDest = Sheets("Data").Range(B) '
For Each slide In pres.Slides
For Each shp In slide.Shapes
If shp.HasTable Then
ExtractTableContent shp.Table, rngDest
Set rngDest = rngDest.Offset(shp.Table.Rows.Count + 3, 0)
End If
Next
Next
ppts.ActivePresentation.Close
FileName = Dir
Loop
End Sub
Sub ExtractTableContent(oTable As Object, rng As Range)
Dim r, c, offR As Long, offC As Long
For Each r In oTable.Rows '<< Loop over each row in the PPT table
offC = 0 '<< reset the column offset
For Each c In r.Cells '<< Loop over each cell in the row
'Copy the cell's text content to Excel, using the offsets
' offR and offC to select where it gets placed relative
' to the starting point (rng)
rng.Offset(offR, offC).Value = c.Shape.TextFrame.TextRange.Text
offC = offC + 1 '<< increment the column offset
Next c
offR = offR + 1 '<< increment the row offset
Next r
End Sub
Sub N()
Range("A3").Value = "New"
End Sub
Here's an example of extracting a table from PPT to Excel.
Looping over the slides and tables (modified from your posted code)
Sub Tester()
Dim ppt As Object, tbl As Object
Dim slide As Object, pres As Object, shp
Dim rngDest As Range
Set ppt = GetObject(, "Powerpoint.Application")
Set pres = ppt.ActivePresentation
Set rngDest = Sheets("Data").Range("a1") '<< where to start placing ppt data
For Each slide In pres.Slides
For Each shp In slide.Shapes
If shp.HasTable Then
ExtractTableContent shp.Table, rngDest
Set rngDest = rngDest.Offset(shp.Table.Rows.Count + 3, 0)
End If
Next
Next
End Sub
The sub to extract each table's data:
Sub ExtractTableContent(oTable As Object, rng As Range)
Dim r, c, offR As Long, offC As Long
For Each r In oTable.Rows '<< Loop over each row in the PPT table
offC = 0 '<< reset the column offset
For Each c In r.Cells '<< Loop over each cell in the row
'Copy the cell's text content to Excel, using the offsets
' offR and offC to select where it gets placed relative
' to the starting point (rng)
rng.Offset(offR, offC).Value = c.Shape.TextFrame.TextRange.Text
offC = offC + 1 '<< increment the column offset
Next c
offR = offR + 1 '<< increment the row offset
Next r
End Sub
In case anyone skims this and wants the solution used
It is out of the box ready, with the exception of setting your file path.
Sub Tester()
Dim rng As Range
Set rng = Range("A1") 'This code is necessary to prevent a constant loop of the formatting for each extraction. It adds a "1" into "A1"
rng.Value = 1
Dim ppts As PowerPoint.Application
Dim FolderPath As String
Dim FileName As String
FolderPath = "FolderPath" 'Define your Folder Path
FileName = Dir(FolderPath & "*.ppt*") 'Locate .PPT files
Do While FileName <> ""
Set ppts = New PowerPoint.Application 'Left this in after finding another fix. Opens new instance each time
ppts.Visible = True
ppts.Presentations.Open FileName:=FolderPath & FileName
'The code below sets 3 variables to help in formatting Tim's extraction code.
'It searches for the last cell entry and then adds 5 rows before copying more information.
A = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 5
B = "B" & A
X = "A" & A
Range(X).Value = "New"
'Beginning of Tim's code
Dim ppt As Object, tbl As Object
Dim slide As Object, pres As Object, shp
Dim rngDest As Range
Set ppt = GetObject(, "Powerpoint.Application")
Set pres = ppt.ActivePresentation
Set rngDest = Sheets("Data").Range(B) 'Moved it over one column for formatting
For Each slide In pres.Slides
For Each shp In slide.Shapes
If shp.HasTable Then
ExtractTableContent shp.Table, rngDest
Set rngDest = rngDest.Offset(shp.Table.Rows.Count + 3, 0)
End If
Next
Next
ppts.ActivePresentation.Close 'Close PPT and loop for next one
FileName = Dir
Loop
End Sub
'More of Tim's code
Sub ExtractTableContent(oTable As Object, rng As Range)
Dim r, c, offR As Long, offC As Long
For Each r In oTable.Rows '<< Loop over each row in the PPT table
offC = 0 '<< reset the column offset
For Each c In r.Cells '<< Loop over each cell in the row
'Copy the cell's text content to Excel, using the offsets
' offR and offC to select where it gets placed relative
' to the starting point (rng)
rng.Offset(offR, offC).Value = c.Shape.TextFrame.TextRange.Text
offC = offC + 1 '<< increment the column offset
Next c
offR = offR + 1 '<< increment the row offset
Next r
End Sub
Sub N()
Range("A3").Value = "New" 'Simply adds "New" next to each new file opened. Helps for deliniation between files
End Sub
I have the code that is used to copy the image from one worksheet and paste it on a new workbook.
My problem is that ' it works only if the image is attached within the range .i want the code that works even if the image is attached over the worksheet'.
Note : input file may contain's multiple image
My code is :
Set xlwbkinput = ActiveWorkbook
Set xlwbkoutput = Excel.Workbooks.Add
shtcountip = xlwbkinput.Sheets.Count
shtcountop = xlwbkoutput.Sheets.Count
If shtcountop < shtcountip Then
For i = shtcountop To shtcountip + 1
xlwbkoutput.Worksheets.Add After:=xlwbkoutput.Worksheets(xlwbkoutput.Worksheets.Count)
Next i
End If
For i = 1 To shtcountip 'it runs till the input workbook have the last sheet
xlwbkinput.Worksheets(i).Activate
xlwbkinput.Worksheets(i).Range("A1:AZ200").Copy 'here I'm copying input sheet
xlwbkoutput.Worksheets(i).Activate
xlwbkoutput.Worksheets(i).Paste 'here I'm pasting in my new worksheet
Next i
Thanks in Advance!!!!
The For loop below will iterate through all shapes in xlwbkinput.Worksheets(1) (which is the worksheet with index 1).
Then it checks if the current Shape (picture) cell position is larger then 1, which means it checks if the current picture's is positioned in any cell which starts from the 2nd row - you can easily modify that criteria.
Dim myPics As Shape
' loop through all shapes in Worksheets(1)
For Each myPics In xlwbkinput.Worksheets(1).Shapes
If myPics.TopLeftCell.Row > 1 Then ' check if current shape's row is larger than 1
myPics.Copy '<-- copy the current picture
End If
Next myPics
Give the following approach a try:
Option Explicit
Public Sub tmpSO()
Dim picIn As Picture
Dim picOut As Picture
Dim wksInput As Worksheet
Dim wksOutput As Worksheet
Dim cht As ChartObject
Set wksInput = ThisWorkbook.Worksheets("Sheet1")
Set wksOutput = ThisWorkbook.Worksheets("Sheet2")
For Each picIn In wksInput.Pictures
Set cht = wksInput.ChartObjects.Add(0, 0, picIn.Width, picIn.Height)
cht.Chart.Parent.Border.LineStyle = 0
picIn.Copy
cht.Chart.ChartArea.Select
cht.Chart.Paste
cht.Chart.Export Filename:=Environ("Temp") & "\someTempPicName.jpg", filtername:="JPG"
Set picOut = wksOutput.Pictures.Insert(Environ("Temp") & "\tmpPic5022.jpg")
picOut.Left = picIn.Left
picOut.Top = picIn.Top
cht.Delete
Kill Environ("Temp") & "\someTempPicName.jpg"
Next picIn
End Sub
This solution uses the worksheet.Pictures collection to iterate through all pictures on a sheet. The easiest way would be to simply .Copy and .Paste these pictures from one sheet to another. Yet, this approach would neglect the location of each picture on the sheet. Assuming that you want you pictures not randomly located on you output sheet, the above code will also copy the location from the input sheet.
I think I've almost got it what I'm trying to do is update a clients report file from my workbook for each shift.
The report is set up with a column with a date/time format (every 2 hours) for each quarter (i.e. "05/05/16 14:00" "05/05/16 16:00" ect).
I have set up my workbook with formulas to report the data in the same format.
report
So what I need it to do is
open the report file
select the data in e18 (cell I've highlighted with red box)
find the cell in the report file
copy the block data with the purple box
paste(values) to matching location based on found data
here is the code I have so far it's finding the data but pasting it in the first row instead of the matching row.
I'm new to VBA so its most likely something simple I didn't understand.
Sub ONGOING()
Dim rFndCell As Range
Dim strData As String
Dim stFnd As String
Dim fCol As Integer
Dim sh As Worksheet
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("REPORTING")
Set sh = Workbooks.Open("F:\report.xlsm").Worksheets("Production data")
stFnd = ws.Range("E18").Value
With sh
Set rFndCell = .Range("A:IV").Find(stFnd, LookIn:=xlValues)
If Not rFndCell Is Nothing Then
fCol = rFndCell.Column
ws.Range("G18:N24").Copy
sh.Cells(6, fCol).Offset(, 2).Resize(7, 8).PasteSpecial xlPasteValues
Else 'Can't find the item
MsgBox "Not Found"
End If
End With
End Sub
Thanks
In IF condition replace
sh.Cells(6, fCol).Offset(, 2).Resize(7, 8).PasteSpecial xlPasteValues
to
sh.Cells(6, fCol).Offset(rFndCell.Row, 2).Resize(7, 8).PasteSpecial xlPasteValues
I am attempting to use VBA to create a chart using dynamic ranges. Specifically, I have an Excel table as follows
Based on this data, I would like to create a chart, with the date ranges changed as per requirement. For example, at one instance, I would be required to produce a chart for 1st July - 6th July, and at another, from 10th July - 14th July.
The following is my attempt at generating such a chart, but I feel there would be much better ways other than mine. Hence, my question, is there any other, better way?
1- I first enter the date values in 'helper cells' for which a chart is sought. In this case, cell M24 has the value 10th July, while cell M26 has the value 14th July.
2- Then, I use the match() function to find the positions from the date column of my Table. The function is =MATCH(M24,Table1[Dates],0), and =MATCH(M26,Table1[Dates],0).
3- Given that I have the relative positions for the dates, I then use the following VBA code to generate the chart:
Private Sub CommandButton1_Click()
Dim mySheet As Worksheet
Dim myShape As Shape
Dim myChart As Chart
Dim myVal1 As String
Dim myVal2 As String
Set mySheet = ActiveWorkbook.Worksheets("dataSheet")
If myShape Is Nothing Then
Set myShape = mySheet.Shapes.AddChart(XlChartType:=xlColumnClustered, _
Left:=CommandButton1.Left + CommandButton1.Width + 2, _
Width:=370, Height:=200)
End If
'In the following, I am offsetting from the first cell
'of my Table, which contains the `value 1-Jul.
'My objective is to use the range 10-Jul to 14th Jul,
'so I also add a column offset
'Cells O24 and O26 contain the results of the match functions
myVal1 = Range("B4").Offset(Range("O24").Value, 0).Address
myVal2 = Range("B4").Offset(Range("O26").Value, 4).Address
Set myChart = myShape.Chart
myChart.ChartType = xlLine
myChart.SetSourceData Source:=Sheets("dataSheet") _
.Range(CStr(myVal1 & ":" & myVal2))
End Sub
So, now hoping that my question is clear, could somebody please educate me of a better method than this one? This seems to be more a hacking method than proper coding to me...
Many thanks in advance!
In my tutorial Chart Partial Range Between Variable Endpoints, I show a couple alternatives using defined Names, without VBA. One way simply gives the index of the first and last record to include in the chart, another uses match to find the range of records that begin and end at dates entered by the user.
As what Dave said, it is pretty solid. But you can try this one:
Private Sub CommandButton1_Click()
Dim d1 As Range, d2 As Range
Dim ws As Worksheet: Set ws = Thisworkbook.Sheets("datasheet")
'~~> Look for the dates
With ws.Range("Table1[Dates]")
Set d1 = .Find(ws.Range("M24").Value, .Cells(.Cells.Count))
Set d2 = .Find(ws.Range("M26").Value, .Cells(.Cells.Count))
End With
'~~> Handle unavailable dates, interchanged inputs
Dim i As Long, j As Long
If d1 Is Nothing Or d2 Is Nothing Then MsgBox "Invalid coverage": Exit Sub
If d2.Value > d1.Value Then i = 0: j = 4 Else i = 4: j = 0
'~~> Set the chart source
Dim chsource As Range
Set chsource = ws.ListObjects("Table1").HeaderRowRange
Set chsource = Union(chsource, ws.Range(d1.Offset(0, i), d2.Offset(0, j)))
'~~> Clean up existing chart
Dim sh As Shape
For Each sh In Me.Shapes
If sh.Type = msoChart Then sh.Delete
Next
'~~> Create the chart
With Me.Shapes.AddChart(, Me.CommandButton1.Left + _
Me.CommandButton1.Width + 2, Me.CommandButton1.Top, _
370, 200).Chart
.ChartType = xlLine
.SetSourceData chsource
.SetElement msoElementChartTitleAboveChart
.ChartTitle.Text = "Trend Chart"
End With
End Sub
You still retrieve dates on M24 and M26 respectively, but no need to use additional ranges with the formulas.
If the values aren't found, it returns a message box.
As long as the dates are found it will create the graph regardless where the user put it.
Also I did 2 ways of accessing the Table, 1 is using Range and the other is using ListObjects.
That is intentional for you to get a hang of both. Sometimes one is better than the other.
Also I am explicit in using Me (which pertains to the sheet that contain your CB).
I also think that your graph should have the correct legends instead of Series(x) names so I added the header to the source. HTH.