I am pasting some excel data into powerpoint as a picture and I am having some issues. I have 290 files which I am pasting a table into slide 4, 5 and 6 of each PP file. This worked perfectly yesterday when I was only doing 1 table into slide 6. I have replicated the process and now I keep getting random errors at random times. Sometimes its file 10, others file 50, different everytime. The errors range from the paste datatype is not available OR the clipboard is empty. I have tried every datatype, pasting as a metafile, as a shape, as a picture, just basic pasting and nothing stops the error. I have no idea! Here is my code: PLEASE HELP !
Sub Update_Site_Report()
'Initiate Variables
Dim objPPT As Object
Dim PPTPrez As Object
Dim FinSlide As Object
Dim AssumSlide As Object
Dim RiskSlide As Object
Dim FinTable As Object
Dim AssumTable As Object
Dim RiskTable As Object
Dim fileNameString As String
Dim PicCount As Long
Dim PicCount1 As Long
Dim PicCount2 As Long
Dim i As Long
Dim fileN As String
Dim Directory As String
'Create and open powerpoint application
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
Application.ScreenUpdating = False
'Update site report table from spreadsheet
For i = 2 To 291
Sheet20.Cells(18, 2) = Sheet20.Cells(5, i)
Sheet20.Cells(19, 2) = Sheet20.Cells(6, i)
Sheet20.Cells(20, 2) = Sheet20.Cells(7, i)
Sheet20.Cells(21, 2) = Sheet20.Cells(8, i)
Sheet20.Cells(18, 3) = Sheet20.Cells(10, i)
Sheet20.Cells(19, 3) = Sheet20.Cells(11, i)
Sheet20.Cells(20, 3) = Sheet20.Cells(12, i)
Sheet20.Cells(21, 3) = Sheet20.Cells(13, i)
'Take column header from spreadsheet and set as filename
fileN = Sheet20.Cells(4, i)
' Allow directory to be set in excel tab
Directory = Sheet20.Cells(18, 5)
'Open powerpoint presentation at Directory with Filename
Set PPTPrez = objPPT.Presentations.Open(Directory & fileN & ".pptx")
'Set range for site report table
Set Financials = Sheet20.Range("A17:C21")
Set Assumptions = Sheet45.Range("A1:C7")
Set Risks = Sheet45.Range("A24:D41")
'Choose which slide to paste site report table
Set FinSlide = PPTPrez.Slides(6)
Set AssumSlide = PPTPrez.Slides(4)
Set RiskSlide = PPTPrez.Slides(5)
'If there is a table in powerpoint slide, delete the table
For PicCount1 = AssumSlide.Shapes.Count To 1 Step -1
If AssumSlide.Shapes(PicCount1).Type = msoPicture Then
AssumSlide.Shapes(PicCount1).Delete
End If
Next
For PicCount = FinSlide.Shapes.Count To 1 Step -1
If FinSlide.Shapes(PicCount).Type = msoPicture Then
FinSlide.Shapes(PicCount).Delete
End If
Next
For PicCount2 = RiskSlide.Shapes.Count To 1 Step -1
If RiskSlide.Shapes(PicCount2).Type = msoPicture Then
RiskSlide.Shapes(PicCount2).Delete
Debug.Print
End If
Next
'Paste the site report table into the site report
Financials.Copy
FinSlide.Shapes.PasteSpecial ppPasteShape
Set FinTable = FinSlide.Shapes(FinSlide.Shapes.Count)
Assumptions.Copy
AssumSlide.Shapes.PasteSpecial ppPasteShape
Set AssumTable = AssumSlide.Shapes(AssumSlide.Shapes.Count)
Risks.Copy
RiskSlide.Shapes.PasteSpecial ppPasteShape
Set RiskTable = RiskSlide.Shapes(RiskSlide.Shapes.Count)
'Set position of site report table in powerpoint
FinTable.Left = 36
FinTable.Top = 175
FinTable.Width = 614
AssumTable.Left = 36
AssumTable.Top = 80.8
RiskTable.Left = 36
RiskTable.Top = 80.8
RiskTable.Width = 641.5
'Set filename as string
fileNameString = Directory & fileN & ".pptx"
'Save file as filename
PPTPrez.SaveAs fileNameString
'Close powerpoint presentation
PPTPrez.Close
'Repeat for every site (column) - increment i
Next i
'quit powerpoint
objPPT.Quit
Application.ScreenUpdating = True
MsgBox ("Update complete, click ok to exit powerpoint")
End Sub
Disabling Windows clipboard history solves this issue.
Related
Sub GetFileList()
Dim xFSO As Object
Dim xFolder As Object
Dim xFile As Object
Dim objOL As Object
Dim Msg As Object
Dim xPath As String
Dim thisFile As String
Dim i As Integer
Dim lastrow As Long
xPath = Sheets("UI").Range("D7")
Set xFSO = CreateObject("Scripting.FileSystemObject")
Set xFolder = xFSO.GetFolder(xPath)
i = 1
For Each xFile In xFolder.Files
i = i + 1
Worksheets("Info").Cells(i, 1) = xPath
Worksheets("Info").Cells(i, 2) = Left(xFile.Name, InStrRev(xFile.Name, ".") - 1)
Worksheets("Info").Cells(i, 3) = Mid(xFile.Name, InStrRev(xFile.Name, ".") + 1)
Worksheets("Info").Cells(i, 6) = Left(FileDateTime(xFile), InStrRev(FileDateTime(xFile), " ") - 1)
Next
Set Msg = Nothing
Worksheets("Info").Visible = True
Worksheets("Info").Activate
End Sub
The code to extract file information from a folder. The issue is when I change the folder path, it overwrites on the previously fetched data.
Sheet -UI is where the sub executed on press of button, Sheet Info is the place where the data needs to be pasted.
How to write the code to add a new row of data after the data which is already available. If the sheet is blank then add data from the 1st ROW otherwise add data from the LAST ROW.
Sheets("UI").Range("A1").End(xlDown).Select
i = Selection.Row + 1
Try replacing
i = 1
with
i = Worksheets("Info").UsedRange.Rows.Count + 1
This will set i to 1 the first time around, and to the first free row ever after. New data will be added below the existing data, if there is any.
I have a Word file with approximately 10 pages and 20 tables. Some of these tables have checkboxes. I want to copy these tables into an Excel file.
The following code copies all tables from my Word file into my Excel file:
Sub Import()
Option Explicit
Dim wb As Workbook
Dim sh As Worksheet
Dim sheet As Worksheet
Dim lzeile As Integer
Set wb = ActiveWorkbook
Set sh = wb.ActiveSheet
Set sheet = wb.Worksheets("Tabelle1")
Dim Btxt As Object
Set Btxt = CreateObject("Word.Application")
Btxt.Visible = True
Btxt.documents.Open "C:\Users\*.doc" '*=path
lzeile = 0
For i = 1 To 20
Btxt.ActiveDocument.Tables(i).Range.Copy
Application.Goto sheet.Cells(1 + lzeile, 1)
sheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
lzeile = sheet.Cells(Rows.Count, 1).End(xlUp).Row
lzeile = lzeile + 1
sheet.Cells(lzeile, 1) = "Tabelle" & i
Next i
Btxt.Quit
Set Btxt = Nothing
Set wb = Nothing
Set sh = Nothing
End Sub
It does not copy checkboxes or the value (0 = not checked / 1 = checked) of the checkbox.
I can write the value of a checkbox into a cell in my excel sheet with this line:
sheet.Cells(j, 10) = Btxt.ActiveDocument.Tables(i).FormFields.Item("Kontrollkästchen" & j).Result
With a loop j over all "Kontrollkästchen" (german translation of contentcontrol or formfield item) so basically the name of all formfield items in this Word file.
How can I get the position of these formfield items or identify which formfield item / ContentControl is in which table?
I tried to go through all rows and columns in each table because none of them are larger than 10x10. But I can´t find a way to check if a checkbox is maybe in table 3 on column 5 row 5 and then read the name of this checkbox to a safe the value (0 / 1) in the Excel cell on the same position in my copied table.
The solution depends on whether they're formfields or content controls.
Assuming they're formfields:
Sub Demo()
Dim i As Long, j As Long, Rng As Range
With ActiveDocument
For i = .FormFields.Count To 1 Step -1
With .FormFields(i)
If .Type = wdFieldFormCheckBox Then
j = Abs(.CheckBox.Value)
Set Rng = .Range
.Delete
Rng.Text = j
End If
End With
Next
End With
End Sub
Assuming they're content controls:
Sub Demo()
Dim i As Long, j As Long, Rng As Range
With ActiveDocument
For i = .ContentControls.Count To 1 Step -1
With .ContentControls(i)
If .Type = wdContentControlCheckBox Then
j = Abs(.Checked)
Set Rng = .Range
.Delete
Rng.Text = j
End If
End With
Next
End With
End Sub
For the sake of simplicity and clarity, the sample code below leaves out the parts having to do with Excel, as well as creating the instance of the Word Application. It shows only how to access the Word document's checkboxes and convert those to static values.
At the end, also, the document is closed without saving changes, which means forms protection and the checkboxes should be left intact - the macro will not have affected them.
Note: You should have Option Explicit at the top of the code page, not inside a "Sub".
How it works
The document to be processed is opened and at that moment set to an object (doc). Use this instead of ActiveDocument as it will be much clearer and, in case the user would try to do something, won't affect macro execution.
If the document has forms protection, this must be turned off in order to delete the checkboxes and insert static values.
Then all the form fields are looped. If they are checkboxes, the value is determined, the checkbox removed and the value assigned to the range the checkbox occupied.
After this has completed comes the code to transfer data to Excel. Then the document is closed without saving changes.
Sub ConvertCheckBoxesToValues()
Dim ff As Object ' Word.FormField
Dim doc As Object ' Word.Document
Dim cbValue As String
Dim rngFF As Object ' Word.Range
Set doc = Btxt.Documents.Open("C:\Users\*.doc") '*=path
If doc.ProtectionType <> -1 Then 'wdNoProtection
doc.Unprotect
End If
For Each ff In doc.FormFields
If ff.Type = 71 Then 'wdFieldFormCheckBox
If ff.CheckBox.value = True Then
cbValue = "1"
Else
cbValue = "0"
End If
Set rngFF = ff.Range
ff.Delete
rngFF = cbValue
End If
Next
'Transfer the information to Excel, then
doc.Close 0 'wdDoNotSaveChanges
End Sub
I'm calling procedure from my main procedure to make header in word, that contains 2 lines of text, then image, then 1 line of text. I'm trying to do that with table that has 1 column and 4 rows. In 3rd row I want picture. Picture is stored on sheet in excel file, that contains all data for report in word. Paste is not working. Can't figure out how to get image in cell.
Found that picture can be added from file, but I don't want to keep picture in separate file, because if I move my excel file I have to move picture file also.
'Procedure, to create header
Sub MakeHeader()
Dim StrArr(1 To 2) As String
Dim RangeObj As Word.Range
'load text from excel table
StrArr(1) = ActiveSheet.Range("A26").Value
StrArr(2) = ActiveSheet.Range("A27").Value
'to create table
Set RangeObj = ActiveDocument.Sections(1).Headers(1).Range
RangeObj.Tables.Add Range:=RangeObj, NumRows:=4, NumColumns:=1
'populate table
'//
RangeObj.Tables(1).Cell(1, 1).Range.Text = StrArr(1)
RangeObj.Tables(1).Cell(2, 1).Range.Text = StrArr(2)
'copy picture that is embedded in excel sheet
'Shapes(4), because there are more then one object in sheet
ActiveSheet.Shapes(4).CopyPicture xlScreen, xlBitmap
RangeObj.Tables(1).Cell(3, 1).Application.Selection.Paste
'//
'center
ActiveDocument.Sections(1).Headers(1).Range.ParagraphFormat.Alignment = 1
End Sub
The main issue in the code is in the line
RangeObj.Tables(1).Cell(3, 1).Application.Selection.Paste
The Picture is getting pasted in the document itself as it is being referred to Application object selection (normally it is not in the header table but in the main document). So changing the line to
RangeObj.Tables(1).Cell(3, 1).Range.Paste
would paste it in the header table as shown below
Also instead of referring ActiveDocument directly in excel VBA (causing problem in some instances of run) it may be referred via Word Application.
The Full modified code:
Sub MakeHeader()
Dim StrArr(1 To 2) As String
Dim RangeObj As Word.Range
'Next line Added for test
Dim wd As Word.Application
'load text from excel table
StrArr(1) = ActiveSheet.Range("A26").Value
StrArr(2) = ActiveSheet.Range("A27").Value
'to create table
'Next Three line Added for test
Set wd = CreateObject("Word.Application")
wd.Visible = True
wd.Documents.Add
'Wd i.e. referance to Word application added to ActiveDocument
Set RangeObj = wd.ActiveDocument.Sections(1).Headers(1).Range
RangeObj.Tables.Add Range:=RangeObj, NumRows:=4, NumColumns:=1
'populate table
'//
RangeObj.Tables(1).Cell(1, 1).Range.Text = StrArr(1)
RangeObj.Tables(1).Cell(2, 1).Range.Text = StrArr(2)
'copy picture that is embedded in excel sheet
'Shapes(4), because there are more then one object in sheet
'shapes(4) modified to Shapes(1) for test. Change to Your requirement
ActiveSheet.Shapes(1).CopyPicture xlScreen, xlBitmap
'This line was causing Problem as Range.Application was referring to Word application
' And picture is getting pasted in the document not in header Table
RangeObj.Tables(1).Cell(3, 1).Range.Paste
'//
'center
'Wd i.e. referance to Word application added to ActiveDocument
wd.ActiveDocument.Sections(1).Headers(1).Range.ParagraphFormat.Alignment = 1
End Sub
Try:
Sub MakeWordHeader()
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim wdRng As Word.Range, wdTbl As Word.Table
Dim xlSht As Excel.Worksheet: Set xlSht = ActiveSheet
With wdApp
.Visible = True
Set wdDoc = .Documents.Add
With wdDoc
Set wdRng = .Sections(1).Headers(1).Range
Set wdTbl = .Tables.Add(Range:=wdRng, NumRows:=4, NumColumns:=1)
With wdTbl
.Cell(1, 1).Range.Text = xlSht.Range("A26").Text
.Cell(2, 1).Range.Text = xlSht.Range("A27").Text
xlSht.Shapes(4).CopyPicture xlScreen, xlBitmap
.Cell(3, 1).Range.Paste
End With
wdRng.ParagraphFormat.Alignment = wdAlignParagraphCenter
End With
End With
End Sub
For someone in future that wants to do something similar, but without Table
'Procedure, to create header
Sub MakeHeader(WApp As Object)
Dim StrArr(1 To 3) As String
Dim ImageObj As Excel.Shape
Dim Doc As Word.Document
Dim i As Long
Dim Count As Long
'load text from excel file
StrArr(1) = ActiveSheet.Range("A26").Value
StrArr(2) = ActiveSheet.Range("A27").Value
StrArr(3) = ActiveSheet.Range("A28").Value
'create object to hold picture
Set ImageObj = ActiveSheet.Shapes(4)
Set Doc = WApp.ActiveDocument
With Doc.Sections(1).Headers(1).Range
'centers text
.ParagraphFormat.Alignment = 1
'choosing font
.Font.Name = "Verdana"
.Font.Size = 9
'writes text
.InsertAfter StrArr(1)
.Paragraphs.Add
.InsertAfter StrArr(2)
.Paragraphs.Add
'creates space for image
For i = 1 To 8
.InsertAfter vbNullString
.Paragraphs.Add
Next
.InsertAfter StrArr(3)
'change font size for paragraphs 1 and 2
.Paragraphs(1).Range.Font.Size = 10
.Paragraphs(2).Range.Font.Size = 10
'copies image form excel file
With ImageObj
.Copy
End With
'collapses selection, 0 = wdCollapseEnd
.Collapse Direction:=0
'paste image, 3 = wdPasteMetafilePicture
.PasteSpecial DataType:=3
'centers image
.ShapeRange.Align msoAlignCenters, True
'lowers it from top of page
.ShapeRange.Top = 35
End With
'counts words in header
Count = Doc.Sections(1).Headers(1).Range.Words.Count
'underlines last two words, count considers ".", "#" and etc. as words
With Doc.Sections(1).Headers(1).Range
.Words(Count - 1).Font.Underline = 1
.Words(Count - 2).Font.Underline = 1
.Words(Count - 3).Font.Underline = 1
.Words(Count - 4).Font.Underline = 1
.Words(Count - 5).Font.Underline = 1
.Words(Count - 6).Font.Underline = 1
.Words(Count - 7).Font.Underline = 1
'don't need to underline comma ","
.Words(Count - 9).Font.Underline = 1
.Words(Count - 10).Font.Underline = 1
.Words(Count - 11).Font.Underline = 1
.Words(Count - 12).Font.Underline = 1
.Words(Count - 13).Font.Underline = 1
.Words(Count - 14).Font.Underline = 1
.Words(Count - 15).Font.Underline = 1
End With
End Sub
I am trying to write a PowerPoint VB application which needs to display certain values from a text file in a fixed format.
When I (manually) open that text file as a csv file in Excel, I get the required values in fixed cells and I know how continue from there by VBA.
What I do not know is how to create the Excel spreadsheet using a macro in PowerPoint.
Also, I want to make sure that the parameters for opening the file (using space as delimiter; multiple spaces count as one) are defined in the macro so that I do not have to rely on current local settings.
Thanks in advance for any idea or reference.
use ~.OpenText
it Supports consecutive delimiter
2.Use text file not with .csv but with .txt extension
Excel fails to load a text with other delimiter if it's extension is '.csv'
Following macro reads a text file with delimiters of space character and copies the Excel table to Powerpoint Table on a Slide.
Full code:
Sub ReadCSV()
Dim xlsApp As Excel.Application
Dim xlsWb As Excel.Workbook
Dim xlsSht As Object 'Excel.Worksheet
Dim rng As Object 'Excel.Range
Dim Target As String
On Error GoTo Oops
'Set xlsApp = New Excel.Application
Set xlsApp = CreateObject("Excel.Application")
xlsApp.Visible = True
Target = ActivePresentation.Path & "\test_space.txt"
'Below don't support consecutive delimiters
'Set xlsWb = xlsApp.Workbooks.Open(FileName:=Target, Format:=3)
'File Extension .CSV won't work here. .TXT works.
xlsApp.Workbooks.OpenText FileName:=Target, Origin:=2, StartRow:=1, _
DataType:=1, ConsecutiveDelimiter:=True, Space:=True, Local:=True
Set xlsWb = xlsApp.ActiveWorkbook
Set xlsSht = xlsWb.Worksheets(1)
Dim sld As Slide
Dim shp As Shape
Dim tbl As Table
Dim numRow As Long, numCol As Long
Dim r As Long, c As Long
Set rng = xlsSht.UsedRange
numRow = rng.Rows.Count
numCol = rng.Columns.Count
With ActivePresentation
Set sld = .Slides.Add(.Slides.Count + 1, ppLayoutBlank)
End With
Set shp = sld.Shapes.AddTable(numRow, numCol, 100, 100, 200, 150)
shp.Name = "Table"
Set tbl = shp.Table
'Copy cell values from Excel Table to Powerpoint Table
For r = 1 To numRow
For c = 1 To numCol
tbl.Cell(r, c).Borders(ppBorderBottom).ForeColor.RGB = rgbBlack
With tbl.Cell(r, c).Shape.TextFrame
If r > 1 Then .Parent.Fill.ForeColor.RGB = rgbWhite
.VerticalAnchor = msoAnchorMiddle
.TextRange = rng.Cells(r, c)
.TextRange.ParagraphFormat.Alignment = ppAlignCenter
End With
Next c
Next r
xlsWb.Close False
Oops:
If Err.Number Then MsgBox Err.Description
'If Excel App remains in the system process, Excel App won't respond and run again.
If Not xlsApp Is Nothing Then xlsApp.Quit: Set xlsApp = Nothing
End Sub
I want to export data from Excel to a pdf-Form using vba.
I used this approach:
https://forums.adobe.com/thread/302309
When I copy just one field it works, but I want to copy all the fields from A1:K2 where the field titles are always in the top and the content in the rows below.
I think my problem is that I don't switch back to Excel when I am trying to copy the next value and field title. But I don't know how to do it properly.
So I would be really glad if someone could tell me.
The files could be downloaded here:
http://www.xn--frank-mller-zhb.net/Formulardings.zip
Sub Pdfdings()
Dim gApp As Acrobat.CAcroApp
Dim avdoc As Acrobat.CAcroAVDoc
Dim gPDDoc As Acrobat.CAcroPDDoc
Const DOC_FOLDER As String = "C:\Users\Frank\Documents"
Dim x As Boolean
Set gApp = CreateObject("AcroExch.App")
Set gPDDoc = CreateObject("AcroExch.PDDoc")
Set avdoc = CreateObject("AcroExch.AVDoc")
'Hides Acrobat - So Far So Good
'gApp.Hide
Dim FormApp As AFORMAUTLib.AFormApp
Dim AcroForm As AFORMAUTLib.Fields
Dim Field As AFORMAUTLib.Field
Dim z, i, j, n As Integer
Dim wksTab1 As Worksheet
Dim Feld, Inhalt As String
Set wksTab1 = Sheets("Tabelle2")
'Open PDF that I choose. Acrobat still has not flashed on my screen
j = 1
i = 2
While i < 3
x = avdoc.Open(DOC_FOLDER & "\formular_ve01a.pdf", "temp")
'Acrobat Now Pops up on my screen. However, I get an error without this line. avdoc.Show works the same as Maximize it seems.
avdoc.Maximize (1)
'Hides it again, right after it opens. This creates a flash
'gApp.Hide
Set FormApp = CreateObject("AFormAut.App")
While j < 39
'If the Maximize line is not there, this is where I receive error about document viewer
Feld = wksTab1.Cells(1, j).Value
Inhalt = wksTab1.Cells(i, j).Value
For Each Field In FormApp.Fields
If Field.Name = Feld Then
Field.Value = Inhalt
End If
Next
j = j + 1
Wend
Dim sDoc
Set sDoc = avdoc.GetPDDoc
saveOk = sDoc.Save(1, DOC_FOLDER & "\OK_Formular" & wksTab1.Cells(1, 1).Value & ".pdf")
avdoc.Close (1)
gApp.Exit
i = i + 1
Wend
End Sub
Set A1:K2 as your print range
Set your printer to a PDF Writer (CutePDF or PDF995 or other)
Print
solution I got by the help of another forum
<pre>While j < 39
'If the Maximize line is not there, this is where I receive error about document viewer
Feld = wksTab1.Cells(1, j).Value
Inhalt = wksTab1.Cells(i, j).Value
FormApp.Fields(Feld).Value = Inhalt
j = j + 1
Wend
Thank you everyone!