I want to copy the print area for landscape in Excel to my Word document, where I run the code from.
I am using
wb.Sheets("Sheet1").Range("A1:N33").Copy
to copy the area, but as the column width changes, it's useless.
Update:
I am using this to calculate my usable dimensions in my Word Document
With ActiveDocument.PageSetup
UsableWidth = .PageWidth - .LeftMargin - .RightMargin
UsableHeight = .PageHeight - .TopMargin - .BottomMargin
End With
I tried to scale my image to fit with:
Selection.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, Placement:=wdInLine, DisplayAsIcon:=False
Selection.ShapeRange.Height = UsableHeight
Selection.ShapeRange.Width = UsableHeight
It does not quite do it. The best approach would be to set the image range before it copies.
Update2:
Dim objExcel As New Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Set wb = objExcel.Workbooks.Open("C:\test.xlsx")
Set ws = wb.Sheets("Sheet1")
This gives an error:
Set rngTemp = ws.Range("A1")
You can retrieve the print area information using this code:
Sub GetPrintArea()
Dim rngPrintArea As Range
'Put print area into range variable
Set rngPrintArea = Sheet1.Range(Sheet1.PageSetup.PrintArea)
'Perform operations on range - shows up in Immediate window:
Debug.Print rngPrintArea.Height
Debug.Print rngPrintArea.Width
Debug.Print rngPrintArea.Cells(rngPrintArea.Rows.Count, rngPrintArea.Columns.Count).Address
End Sub
This does not work if a print area is not already set - can you confirm if the Excel sheets are already set to landscape with a print area defined? If not, you'll need to find the paper dimensions and loop through cells until you find those which share the same Left and Top values (I think). You can set the PrintArea like this:
'Set print area
Sheet1.PageSetup.PrintArea = "$A1:$N33"
EDIT - This should do what you need now we know that the source dimensions are predefined - you'll need to set UseableWidth and UseableHeight in Word and either bring them into this sub using ByVal or a public variable:
Sub FindRange()
Dim rngTemp As Range, rngCopy As Range, rngTest As Range
Dim iCol As Integer, iRow As Integer
Set rngTemp = Sheet1.Range("A1")
'Get closest column
Do Until rngTemp.Left >= UseableWidth
Set rngTemp = rngTemp.Offset(0, 1)
Loop
iCol = rngTemp.Column
'Get closest row
Do Until rngTemp.Top >= UseableHeight
Set rngTemp = rngTemp.Offset(1, 0)
Loop
iRow = rngTemp.Row
Set rngCopy = Sheet1.Range("A1", Sheet1.Cells(iRow, iCol))
'Copy rngCopy into Word as you were before
End Sub
Related
I am new in VBA, so I am not familiar with all its capabilities. I have a worksheet with many "tables" in it. By tables, I do not mean actual Excel Table Object but chunks of data that are separated into "tables" via color/border formatting.
I can find which cell a specific table starts by finding the cell which contains "RefNum:". However, to avoid false detection of table, I would like to double check the next cells after it.
Essentially, what I want is not just to find "RefNum:" but to find the position of 3x1 array which contains the ff in correct order:
- RefNum:
- Database:
- ToolID:
Only then can I be sure that what I found was a real table.
I am thinking of finding "RefNum:" and doing if-else for verification, but maybe there is a more sophisticated way of doing it?
Thanks for the help.
Try this code:
Sub FindTables()
Dim cell As Range
Dim firstAddress As String
With Range(Cells(1, 1), Cells(Rows.Count, Columns.Count))
Set cell = .Find("RefNum", LookIn:=xlValues)
firstAddress = cell.Address
Do
'check cell next to "RefNum" and one after that
If LCase(cell.Offset(0, 1).Value) = "database" And LCase(cell.Offset(0, 2).Value) = "toolid" Then
'here, cell is first cell (ref num) of the table
cell.Interior.ColorIndex = 4
End If
Set cell = .FindNext(cell)
Loop While Not cell Is Nothing And cell.Address <> firstAddress
End With
End Sub
Based from Michal's code, this is the answer I came up with. It works well except for one thing. It does not detect the 1st cell address, only the 2nd and succeeding. Can anyone see where I made an error?
Option Explicit
Public Sub LogSum()
'Declare variables
Dim shtMacro As Worksheet 'Sheet where macro button is located
Dim Fname As Variant 'List of user-selected files
Dim bookLOG As Workbook 'Active logsheet file
Dim shtLOG As Worksheet 'Active worksheet from current active workbook
Dim WS_Count As Integer 'Number of worksheets in active workbook
Dim CellDB As Range 'First cell output for find "RefNum"
Dim FirstAddress As String 'Address of the first CellDB
Dim i As Integer, j As Integer 'Loop iterators
'Prompt user to get logsheet filenames
Fname = Application.GetOpenFilename("ALL files (*.*), *.*,Excel Workbook (*.xlsx), *.xlsxm,Excel 97-2003 (*.xls), *.xls", , "Open Logsheet Files", , True)
If (VarType(Fname) = vbBoolean) Then Exit Sub
DoEvents
'Iterate per workbook
For i = LBound(Fname) To UBound(Fname)
Set bookLOG = Workbooks.Open(Filename:=Fname(i), UpdateLinks:=0, _
ReadOnly:=True, IgnoreReadOnlyRecommended:=True) 'Open workbook i
WS_Count = bookLOG.Worksheets.Count 'Store max number of sheets
Debug.Print bookLOG.Name 'Print the workbook filename in log
'Iterate per worksheet in workbook i
For j = 1 To WS_Count
Debug.Print bookLOG.Worksheets(j).Name 'Print the current sheet in log
Set CellDB = bookLOG.Worksheets(j).UsedRange.Find("RefNum:", LookIn:=xlValues) 'Search for "RefNum:"
If (Not (CellDB Is Nothing)) Then
bookLOG.Worksheets(j).UsedRange.Select
Debug.Print "Something's found here."
FirstAddress = CellDB.Address 'Assign the 1st search address
Debug.Print FirstAddress
Do 'Check cell next to "RefNum:" and one after that
If CellDB.Offset(1, 0).Value = "DATABASE: " And CellDB.Offset(2, 0).Value = "Tester:" Then
Debug.Print "Yay! Got You"
Debug.Print CellDB.Address
Else
Debug.Print "Oops. False Alarm"
End If
Set CellDB = bookLOG.Worksheets(j).UsedRange.FindNext(CellDB)
Loop While CellDB.Address <> FirstAddress
Else
Debug.Print "Nothing found here."
End If
Next j
Next i
End Sub
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 following VBA code that works to export a range of cells into a jpeg into a specified folder. I would like to have it loop through all worksheets in one workbook.
I need help looping this code through all open workbooks. I believe I will need to:
Dim WS As Worksheet, then set up an If statement, insert the below code, end the if statement, then at the end put a Next WS for it to actually loop through. My problem is, is that I keep getting a 91 error when I try to combine my if statement, For Each WS In ThisWorkbook.Sheets If Not WS.Name = "Sheet2" Then, with my code below.
The following code works in one worksheet at a time.
Sub ExportAsImage()
Dim objPic As Shape
Dim objChart As Chart
Dim i As Integer
Dim intCount As Integer
'copy the range as an image
Call ActiveSheet.Range("A1:F2").CopyPicture(xlScreen, xlPicture)
'remove all previous shapes in the ActiveSheet
intCount = ActiveSheet.Shapes.Count
For i = 1 To intCount
ActiveSheet.Shapes.Item(1).Delete
Next i
'create an empty chart in the ActiveSheet
ActiveSheet.Shapes.AddChart
'select the shape in the ActiveSheet
ActiveSheet.Shapes.Item(1).Select
ActiveSheet.Shapes.Item(1).Width = Range("A1:F2").Width
ActiveSheet.Shapes.Item(1).Height = Range("A1:F2").Height
Set objChart = ActiveChart
'clear the chart
objChart.ChartArea.ClearContents
'paste the range into the chart
objChart.Paste
'save the chart as a JPEG
objChart.Export ("C:\Users\------\Desktop\Test\" & Range("B2").Value & ".jpg")
'remove all shapes in the ActiveSheet
intCount = ActiveSheet.Shapes.Count
For i = 1 To intCount
ActiveSheet.Shapes.Item(1).Delete
Next i
End Sub
Add this to your module:
Sub MAIN()
Dim sh As Worksheet
For Each sh In Sheets
sh.Activate
Call ExportAsImage
Next sh
End Sub
and run it. (there is no need to modify your code)
I manage to copy a range from excel to a newly opened WORD document and control the line spacing (thanks to some help Copy range from excel to word - set paragraph spacing to zero).
However, I do not manage to control the linespacing when I copy multiple ranges to multiple bookmarks in an opened and existing word file (document.docx). The code can be found below at the end of the post.
This code works for an excel file with multiple sheets. One sheet is a configuration sheet. It contains the name of the excel sheet containing the table (in range "Name") and links this to the bookmark name in word (in range BookmarkExcel")".
I suppose the problem is with this piece of the code:
Set wdTable = myDoc.Tables(myDoc.Tables.Count)
wdTable.Range.ParagraphFormat.SpaceAfter = 0
I tried all sorts of variations (e.g. replacing myDoc.Tables.Count by rep, 1, ...) but didn't manage to control the linespacing. What did I do wrong?
EDIT: I found the cause: the document contains already some tables (before and after the ones that I copy and paste) which causes the code for the line spacing not to work. Thus, how can I adapt my code such that it works for documents that already contain tables?
Sub ExcelTablesToWord()
Dim tbl As Range
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table
Sheets("Configuration").Select
n = ActiveSheet.UsedRange.Rows.Count
Set ListTables = Range("Name")
Set ListExcelBookmarks = Range("BookmarkExcel")
Set WordApp = GetObject(class:="Word.Application")
WordApp.Visible = True
Set myDoc = WordApp.Documents("document.docx")
For rep = 2 To n
SheetName = ListTables.Cells(rep, 1).Value
On Error Resume Next
Set existing = Sheets(SheetName)
existing.Select 'added this
lastColumn = ActiveSheet.UsedRange.Columns.Count
LastRow = ActiveSheet.UsedRange.Rows.Count
If ListExcelBookmarks.Cells(rep, 1).Value <> "" Then
Set tbl = Range(Cells(1, 1), Cells(LastRow, lastColumn))
tbl.Copy
myDoc.Bookmarks(ListExcelBookmarks.Cells(rep, 1).Value).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
Dim wdTable As Table
Set wdTable = myDoc.Tables(myDoc.Tables.Count)
wdTable.Range.ParagraphFormat.SpaceAfter = 0
End If
Next rep
End Sub
count the tables up to current bookmark and then add one to get the newly added table index
here's your code with what above and some other (hopefully) useful refactoring:
Option Explicit
Sub ExcelTablesToWord()
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim wdTable As Table
Dim rep As Long
Dim ListTables As Range
Dim ListExcelBookmarks As Range
Dim ws As Worksheet
Dim tabName As String
Set WordApp = GetObject(class:="Word.Application")
WordApp.Visible = True
Set myDoc = WordApp.Documents("document.docx")
With Worksheets("Configuration")
Set ListTables = .Range("Name")
Set ListExcelBookmarks = .Range("BookmarkExcel")
End With
For rep = 2 To ListExcelBookmarks.Rows.Count '<--| loop through bookmarks range, skipping first row
If ListExcelBookmarks.Cells(rep, 1).Value <> "" Then
tabName = ListTables.Cells(rep, 1).Value
If GetSheet(tabName, ws) Then '<-- GetSheet() returns 'True' if a worksheet named after 'tabName' is found and sets 'ws' to it. Otherwise it returns 'False'
ws.UsedRange.Copy
With myDoc
.Bookmarks(tabName).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
Set wdTable = .Tables(.Range(.Range.Start, .Bookmarks(tabName).Range.End).Tables.Count + 1) '<--| add one to the tables before current bookmark to get the newly added one right after it
wdTable.Range.ParagraphFormat.SpaceAfter = 0
End With
End If
End If
Next rep
End Sub
Function GetSheet(shtName As String, ws As Worksheet) As Boolean
On Error Resume Next
Set ws = Worksheets(shtName)
GetSheet = Not ws Is Nothing
End Function
I need to activate a specific worksheet. The code is meant to create worksheets with a specif name. I need to paste something from a another worksheet into all these newly created worksheets. The code that I'm using is below. But I'm having a hard time activating the newly created worksheet to paste what I want.
Sub octo()
'Dim ws As Worksheet
Dim Ki As Range
Dim ListSh As Range
Workbooks.Open ("C:\Users\Dash\Dropbox\Randika\Misc\Emmash timesheets\timesheet.xlsx")
With Worksheets("PPE 05-17-15")
Set ListSh = .Range("B4:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
End With
On Error Resume Next
For Each Ki In ListSh
If Len(Trim(Ki.Value)) > 0 Then
If Len(Worksheets(Ki.Value).Name) = 0 Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Ki.Value
'open template
Workbooks.Open ("C:\Users\Dash\Dropbox\Randika\Misc\Emmash timesheets\octo_template.xls")
Range("A1:L31").Select
Selection.Copy
Worksheets(Ki.Value).Activate
If ThisWorkbook.Saved = False Then
ThisWorkbook.Save
End If
End If
End If
Next Ki
End Sub
Both Workbooks.Open and Worksheets.Add return references to the opened and added objects, which you can use to directly access and modify them - and in your case, to paste data.
Example:
Dim oSourceSheet As Worksheet
Dim oTargetSheet As Worksheet
Set oSourceSheet = Sheet1 'Set reference to any sheet, Sheet1 in my example
Set oTargetSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
oSourceSheet.Range("A1:L31").Copy
oTargetSheet.Paste
Set oSourceSheet = Nothing
Set oTargetSheet = Nothing
I think that is what you need. As what been mentioned by chris, there is no need Activate or Select. Hope the following code solve your problem.
Option Explicit
Dim MyTemplateWorkbook As Workbook
Dim MyDataWorkbook As Workbook
Dim MyTemplateWorksheet As Worksheet
Dim MyDataWorksheet As Worksheet
Dim MyNewDataWorksheet As Worksheet
Dim CurrentRange As Range
Dim ListRange As Range
Sub AddWSAndGetData()
Set MyTemplateWorkbook = Workbooks.Open("C:\Users\lengkgan\Desktop\Testing\MyTemplate.xlsx")
Set MyTemplateWorksheet = MyTemplateWorkbook.Sheets("Template")
Set MyDataWorkbook = Workbooks.Open("C:\Users\lengkgan\Desktop\Testing\MyData1.xlsx")
Set MyDataWorksheet = MyDataWorkbook.Sheets("PPE 05-17-15")
Set ListRange = MyDataWorksheet.Range("B4:B" & MyDataWorksheet.Cells(Rows.Count, "B").End(xlUp).Row)
Application.ScreenUpdating = False
On Error Resume Next
For Each CurrentRange In ListRange
If Len(Trim(CurrentRange.Value)) > 0 Then
If Len(MyDataWorksheet(CurrentRange.Value).Name) = 0 Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CurrentRange.Value
Set MyNewDataWorksheet = MyDataWorkbook.Sheets(ActiveSheet.Name)
MyNewDataWorksheet.Range("A1:L31").Value = MyTemplateWorksheet.Range("A1:L31").Value
If MyDataWorkbook.Saved = False Then
MyDataWorkbook.Save
End If
End If
End If
Next CurrentRange
MyTemplateWorkbook.Close (False) 'Close the template without saving
End Sub