I have a container that contains two tables : CH10001 and CH10002
with the following code I can export CH10001
sub xport2xl()
iRow = 1
set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
set xlWB = xlApp.Workbooks.Add
set xlSheet = xlWB.Worksheets(1)
set obj = ActiveDocument.getsheetobject(ChartName)
xlSheet.Activate
xlSheet.Cells.Clear
while not (isempty(xlSheet.Cells(iRow,1)))
iRow = iRow+2
wend
set txt1 = ActiveDocument.GetSheetObject("CH10001")
txt1.CopytableToClipboard TRUE
xlSheet.Cells(iRow,1).Select
xlSheet.Paste
end sub
How can I export CH10001 and CH10002 in the same workbook but with dynamic sheet name? And add the getdate in the name of the sheet for example?
If you want to export these tables in separeted sheets, this should help you :
Sub xport2xl()
iRow = 1
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add
Set xlSheet = xlWB.Worksheets(1)
Set obj = ActiveDocument.GetSheetObject(ChartName)
xlSheet.Activate
xlSheet.Cells.Clear
While Not (IsEmpty(xlSheet.Cells(iRow, 1)))
iRow = iRow + 2
Wend
Set txt1 = ActiveDocument.GetSheetObject("CH10001")
txt1.CopytableToClipboard True
'xlSheet.Activate '---You might need to activate sheet
xlSheet.Cells(iRow, 1).Paste
'-----Set the name of the sheet here----
xlSheet.Name = "Your name here for CH10001"
'----------------------------------------------------
'------------ Code for the second table -------------
'----------------------------------------------------
On Error Resume Next
'---Try to set the second sheet
Set xlSheet = xlWB.Worksheets(2)
If Err.Number <> 0 Then
'---If there is an error, add a new sheet
Set xlSheet = xlWB.Worksheets.Add
Else
'---Already assigned, nothing else to do
End If
On Error GoTo 0
Set txt1 = ActiveDocument.GetSheetObject("CH10002")
txt1.CopytableToClipboard True
'xlSheet.Activate '---You might need to activate sheet
xlSheet.Cells(iRow, 1).Paste
'-----Set the name of the sheet here----
xlSheet.Name = "Your name here for CH10002"
End Sub
Related
For the purpose of sales department I have a query that tracks previous price points and calculates margins. I would like to export this info to Excel to create a combo chart to make the information more visual. I've found some sample code on another site, but it doesn't quite do everything I need. I've used the macro recorder to come up with my desire code, but it uses different methods than my sample code. Can anyone help me to combine the following codes to come up with Combo Charts via VBA?
'sample code below
Private Sub Command201_Click()
Option Compare Database
Private Const conQuery = "qryTopTenProducts"
Private Const conSheetName = "Top 10 Products"
Private Sub Command201_Click()
Dim rst As ADODB.Recordset
' Excel object variables
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlChart As Excel.Chart
Dim i As Integer
On Error GoTo HandleErr
' Create Excel Application object.
Set xlApp = New Excel.Application
' Create a new workbook.
Set xlBook = xlApp.Workbooks.Add
' Get rid of all but one worksheet.
xlApp.DisplayAlerts = False
For i = xlBook.Worksheets.Count To 2 Step -1
xlBook.Worksheets(i).Delete
Next i
xlApp.DisplayAlerts = True
' Capture reference to first worksheet.
Set xlSheet = xlBook.ActiveSheet
' Change the worksheet name.
xlSheet.Name = conSheetName
' Create recordset.
Set rst = New ADODB.Recordset
rst.OPEN _
Source:=conQuery, _
ActiveConnection:=CurrentProject.Connection
With xlSheet
' Copy field names to Excel.
' Bold the column headings.
With .Cells(1, 1)
.Value = rst.Fields(0).Name
.Font.Bold = True
End With
With .Cells(1, 2)
.Value = rst.Fields(1).Name
.Font.Bold = True
End With
' Copy all the data from the recordset
' into the spreadsheet.
.Range("A2").CopyFromRecordset rst
' Format the data.
.Columns(1).AutoFit
With .Columns(2)
.NumberFormat = "#,##0"
.AutoFit
End With
End With
' Create the chart.
Set xlChart = xlApp.Charts.Add
With xlChart
.ChartType = xlComboColumnClusteredLine
.SetSourceData xlSheet.Cells(1, 1).CurrentRegion
.PlotBy = xlColumns
.Location _
Where:=xlLocationAsObject, _
Name:=conSheetName
End With
' Setting the location loses the reference, so you
' must retrieve a new reference to the chart.
With xlBook.ActiveChart
.HasTitle = True
.HasLegend = False
With .ChartTitle
.Characters.Text = conSheetName & " Chart"
.Font.Size = 16
.Shadow = True
.Border.LineStyle = xlSolid
End With
With .ChartGroups(1)
.GapWidth = 20
.VaryByCategories = True
End With
.Axes(xlCategory).TickLabels.Font.Size = 8
.Axes(xlCategoryScale).TickLabels.Font.Size = 8
End With
' Display the Excel chart.
xlApp.Visible = True
ExitHere:
On Error Resume Next
' Clean up.
rst.Close
Set rst = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
Exit Sub
HandleErr:
MsgBox Err & ": " & Err.Description, , "Error in CreateExcelChart"
Resume ExitHere
End Sub
'macro recorded code
ActiveSheet.Shapes.AddChart2(201, xlColumnClustered).Select
ActiveChart.SetSourceData Source:=Range("'PART TARGET'!$A$1:$E$5")
ActiveChart.FullSeriesCollection(1).ChartType = xlColumnClustered
ActiveChart.FullSeriesCollection(1).AxisGroup = 1
ActiveChart.FullSeriesCollection(2).ChartType = xlColumnClustered
ActiveChart.FullSeriesCollection(2).AxisGroup = 1
ActiveChart.FullSeriesCollection(3).ChartType = xlColumnClustered
ActiveChart.FullSeriesCollection(3).AxisGroup = 1
ActiveChart.FullSeriesCollection(4).ChartType = xlLine
ActiveChart.FullSeriesCollection(4).AxisGroup = 1
ActiveChart.FullSeriesCollection(5).ChartType = xlLine
ActiveChart.FullSeriesCollection(5).AxisGroup = 1
ActiveChart.FullSeriesCollection(4).ChartType = xlColumnClustered
ActiveChart.FullSeriesCollection(4).AxisGroup = 2
ActiveChart.FullSeriesCollection(3).ChartType = xlLine
The problem breaks into two parts. Exporting the data to Excel and then having Excel create a Combo Chart. If you are creating the Excel file you can use Access's Export Data Wizard to create a saved export of almost anything in access. Then its a simple call to:
DoCmd.RunSavedImportExport "Export-MyTabletoExcel"
If you already have an Excel File with a macro for creating the chart from where the data goes then you can create the chart by simply calling the macro from Access
runExcelMacro "C:\Users\bubblegum\Desktop\test2.xlsm", "CreateComboChart"
Public Sub runExcelMacro(wkbookPath, macroName)
'adapted from https://access-excel.tips/run-excel-macro-from-access-vba/
Dim XL As Object
Set XL = CreateObject("Excel.Application")
With XL
.Visible = False
.displayalerts = False
.Workbooks.Open wkbookPath
.Run macroName
.ActiveWorkbook.Close (True)
.Quit
End With
Set XL = Nothing
End Sub
But if you have to create the Excel file it will not have a Macro yet so it is best to create that macro in Excel then translate it to Access vba:
Sub CreateComboChart()
' CreateComboChart Macro
Range("B1:D7").Select
ActiveSheet.Shapes.AddChart2(201, xlColumnClustered).Select
ActiveChart.SetSourceData Source:=Range("Table4!$B$1:$D$7")
ActiveChart.FullSeriesCollection(1).ChartType = xlColumnClustered
ActiveChart.FullSeriesCollection(1).AxisGroup = 1
ActiveChart.FullSeriesCollection(2).ChartType = xlColumnClustered
ActiveChart.FullSeriesCollection(2).AxisGroup = 1
ActiveChart.FullSeriesCollection(3).ChartType = xlLine
ActiveChart.FullSeriesCollection(3).AxisGroup = 1
End Sub
became:
Public Sub CreateComboChartinExcel()
'Required: Tools > Refences: Add reference to Microsoft Excel Object Library
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlChart As Excel.Chart
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open("C:\Users\bubblegum\Desktop\test.xlsm")
Set xlSheet = xlBook.ActiveSheet
xlSheet.Range("B1:D7").Select
xlSheet.Shapes.AddChart2(201, xlColumnClustered).Select
Set xlChart = xlBook.ActiveChart
xlChart.SetSourceData Source:=xlSheet.Range("B1:D7")
xlChart.FullSeriesCollection(1).ChartType = xlColumnClustered
xlChart.FullSeriesCollection(1).AxisGroup = 1
xlChart.FullSeriesCollection(2).ChartType = xlColumnClustered
xlChart.FullSeriesCollection(2).AxisGroup = 1
xlChart.FullSeriesCollection(3).ChartType = xlLine
xlChart.FullSeriesCollection(3).AxisGroup = 1
xlBook.Save 'surprisingly important
xlBook.Close
xlApp.Quit
Set xlBook = Nothing
Set xlApp = Nothing
End Sub
Finally, the Access Export Wizard neither lets you append the exported data to the Excel file or lets you see the VBA. So if you want to paste to an Excel file you have to either use Docmd.TransferSpreadsheet or loop through the Access tables and copy and paste to excel. I show Docmd:
Public Sub TransferTable()
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "myTable", "C:\Users\bubblegum\Desktop\test.xlsx"
End Sub
I need VBA Code to get header bookmark in the Excel UserForm1 Textbox. Please assist me. I have got the page count, but not able to get this. I have placed the Code below, which I've tried, but it is not working.
I get error at:
Set wbk = ObjExcel.Workbooks.Open("C:\Users\Desktop\Test-2.xlsm")
and
wst.txtstatementof.Text = "MyBookmark"
Thanks in advance.
Sub ExportBookmarksToExcel()
Dim bk As Bookmark
Dim appXl As Excel.Application
Dim wbk As Excel.Workbook
Dim wst As Excel.Worksheet
Dim x As UserForm1
Set appXl = CreateObject("Excel.Application")
Set wbk = ObjExcel.Workbooks.Open("C:\Users\Desktop\Test-2.xlsm")
With appXl
.Visible = True
Set wbk = .Workbooks.Add
Set wst = wbk.UserForm1
wst.txtstatementof.Text = "MyBookmark"
End With
'For each bk In ActiveDocument.Bookmarks
'lRow = lRow + 1
' wst.x.UserForm1.txtstatementof.Text = bk.Name
'wst.Cells(lRow, 2) = bk.Range.Text
'Next bk
'wst.UsedRange.Columns.AutoFit
End Sub
Actually, you weren't far from success. Of course, this must fail:-
Set appXl = CreateObject("Excel.Application")
Set wbk = ObjExcel.Workbooks.Open("C:\Users\Desktop\Test-2.xlsm")
You can see that your Excel application is called appXl. Therefore it can't respond to ObjExcel.Workbooks.Open.
Below is the code that works.
Sub ExportBookmarksToExcel()
' MS Word variables:
Dim Bk As Bookmark
Dim R As Long
' MS Excel variables:
Dim appXl As Excel.Application
Dim Wbk As Excel.Workbook
Dim Wst As Excel.Worksheet
Set appXl = CreateObject("Excel.Application")
With appXl
.Visible = True
' Set Wbk = .Workbooks.Open("C:\Users\Desktop\Test-2.xlsm")
Set Wbk = .Workbooks.Add
Set Wst = Wbk.Worksheets(1)
' Wst.txtstatementof.Text = "MyBookmark" ' what is "txtstatementof" ?
End With
R = 2 ' keep Row 1 for captions
For Each Bk In ActiveDocument.Bookmarks
Wst.Cells(R, 1) = Bk.Name
Wst.Cells(R, 2) = Bk.Range.Text
R = R + 1
Next Bk
Wst.UsedRange.Columns.AutoFit
End Sub
Hi I justed posted a few minutes ago and somone asnwerd my question about excel not closing. I am using access to open a sheet and add a table. Excel won't close which causes issues down the road as when I get the excel object again in another function the sheet I am working with won't open and it won't format it. Here is my code. I thought I was explicit here but maybe I am not. Excel just won't closed.
Public Function BrooksFormatTableBrooks()
Dim xlApp As Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
bfile = "S:\_Reports\Brooks\Tyco-Brooks Receiving Tracking MASTER - "
MyFileName = bfile & Format(Date, "mm-dd-yyyy") & ".xls"
On Error Resume Next
Set xlApp = CreateObject("Excel.Application")
On Error GoTo 0
Set wb = xlApp.Workbooks.Open(MyFileName)
Set ws = wb.Sheets(1)
ws.Activate
wb.Sheets(1).Name = "RSSR_List"
Set ws = wb.Sheets(1)
ws.Activate
xlApp.ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$F$312"), , xlYes).Name = _
"RSSR"
ws.Range("A1:F312").Select
DoEvents
ws.Cells.Rows("2:2").Select
xlApp.ActiveWindow.FreezePanes = False
xlApp.ActiveWindow.FreezePanes = True
ws.Columns("A:Z").HorizontalAlignment = xlCenter
ws.Rows("1:1").Font.Bold = True
ws.Rows("1:1").Font.ColorIndex = 1
ws.Rows("1:1").Interior.ColorIndex = 15
ws.Cells.Font.Name = "Calbri"
ws.Cells.Font.Size = 8
ws.Cells.EntireColumn.AutoFit
ws.Cells.EntireRow.AutoFit
xlApp.Cells.Borders.LineStyle = xlContinuous
xlApp.Cells.Borders.Weight = xlThin
xlApp.Cells.Borders.ColorIndex = 0
ws.Cells.Rows("1:1").Select
wb.CheckCompatibility = False
wb.Save
wb.CheckCompatibility = True
wb.Close SaveChanges:=True
xlApp.Quit
Set xlApp = Nothing
Set wb = Nothing
Set ws = Nothing
MsgBox "Table Add"
End Function
Replace Range("$A$1:$F$312") with ws.Range("$A$1:$F$312") or else you will still have a reference to an Excel Application object that won't be destroyed until you exit MSAccess.
I'm playing around with this code snippet, which I found on SO.
Sub Test()
Dim objWord As Object
Dim ws As Worksheet
Set ws1 = ThisWorkbook.Sheets("Contact Information1")
Set ws2 = ThisWorkbook.Sheets("Contact Information2")
'Set ws3 = ThisWorkbook.Sheets("Contact Information3")
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Documents.Open "C:\Users\rshuell001\Desktop\Final Report.docx" ' change as required
With objWord.ActiveDocument
.Bookmarks("BkMark1").Range.Text = ws1.Range("A1:F24").Value
.Bookmarks("BkMark2").Range.Text = ws2.Range("A1:F8").Value
'.Bookmarks("Report3").Range.Text = ws3.Range("A1:F80").Value
End With
Set objWord = Nothing
End Sub
When I look at it, it makes sense. When I run the script, I get an error on this line:
.Bookmarks("BkMark1").Range.Text = ws1.Range("A1:F24").Value
The error message is:
Run-type error 13
Type mismatch
1) I'm not sure '.Bookmarks("BkMark1").Range.Text' will do what I want. I think it's more of a standard copy/paste.
2) I want to make sure the table fits in the Word document, so I'm going to need something like the line below, to get it to do what I want.
wd.Tables(1).AutoFitBehavior wdAutoFitWindow
Any ideas on how to make this work?
Thanks!
I came up with the script below. It does what I want.
Sub Export_Table_Word()
'Name of the existing Word doc.
'Const stWordReport As String = "Final Report.docx"
'Word objects.
Dim WDApp As Word.Application
Dim WDDoc As Word.Document
Dim wdbmRange1 As Word.Range
'Excel objects.
Dim wbBook As Workbook
Dim wsSheet1 As Worksheet
Dim rnReport1 As Range
'Initialize the Excel objects.
Set wbBook = ThisWorkbook
Set WDApp = New Word.Application
'Set wdDoc = wdApp.Documents.Open(wbBook.Path & "\" & stWordReport)
Set WDDoc = WDApp.Documents.Open("C:\Users\rshuell001\Desktop\Final Report.docx")
'Delete old fields and prepare to replace with new
Dim doc As Document
Dim fld As Field
Set doc = WDDoc
For Each fld In doc.Fields
fld.Select
If fld.Type = 88 Then
fld.Delete
End If
Next
Set wsSheet = wbBook.Worksheets("Contact Information1")
Set rnReport = wsSheet.Range("BkMark1")
Set wdbmRange = WDDoc.Bookmarks("BkMark1").Range
'Turn off screen updating.
Application.ScreenUpdating = False
'Copy the report to the clipboard.
rnReport.Copy
'Select the range defined by the "Report" bookmark and paste in the report from clipboard.
With wdbmRange
.Select
.Paste
End With
WDDoc.Tables(1).AutoFitBehavior wdAutoFitWindow
Set wsSheet = wbBook.Worksheets("Contact Information2")
Set rnReport = wsSheet.Range("BkMark2")
Set wdbmRange = WDDoc.Bookmarks("BkMark2").Range
Application.ScreenUpdating = False
rnReport.Copy
With wdbmRange
.Select
.Paste
End With
WDDoc.Tables(2).AutoFitBehavior wdAutoFitWindow
Set wsSheet = wbBook.Worksheets("Contact Information3")
Set rnReport = wsSheet.Range("BkMark3")
Set wdbmRange = WDDoc.Bookmarks("BkMark3").Range
Application.ScreenUpdating = False
rnReport.Copy
With wdbmRange
.Select
.Paste
End With
WDDoc.Tables(3).AutoFitBehavior wdAutoFitWindow
'Save and close the Word doc.
With WDDoc
.Save
.Close
End With
'Quit Word.
WDApp.Quit
'Null out your variables.
Set fld = Nothing
Set doc = Nothing
Set wdbmRange = Nothing
Set WDDoc = Nothing
Set WDApp = Nothing
'Clear out the clipboard, and turn screen updating back on.
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
MsgBox "The report has successfully been " & vbNewLine & _
"transferred to " & stWordReport, vbInformation
End Sub
Im trying to copy and paste a table from excel into a word document.
I can do it manually - highlight the cell, CTRL+C, go to word, CTRL+V. it works fine.
But when I write a macro to do it the cells are twice the height, like the line height in each cell gets changed for some reason. why is it different? I recorded the manual procedure and it is the same function (PasteExcelTable) being called.
Set wordDoc = wordApp.Documents.Open(wordDocPath)
With wordDoc
' cost report
Dim wordRng As Word.Range
Dim xlRng As Excel.Range
Dim sheet As Worksheet
Dim i As Integer
Dim r As String
'Copy the cost report from excel sheet
Set sheet = ActiveWorkbook.Sheets("COST REPORT")
i = sheet.Range("A:A").Find("TOTAL PROJECT COST", Range("A1"), xlValues, xlWhole, xlByColumns, xlNext).row
r = "A11:M" + Trim(Str(i))
Set xlRng = sheet.Range(r)
xlRng.Copy
'Copy and Paste Cost report from Excel
Set wordRng = .Bookmarks("CostReport").Range 'remember original range
If .Bookmarks("CostReport").Range.Information(wdWithInTable) Then
.Bookmarks("CostReport").Range.Tables(1).Delete
End If
.Bookmarks("CostReport").Range.PasteExcelTable False, False, False
.Bookmarks.Add "CostReport", wordRng 'reset range to its original positions
End With
Here is my solution:
With wordDoc
'Paste table from Excel
Set wordRng = .Bookmarks(bookMarkName).range 'remember original range
If .Bookmarks(bookMarkName).range.Information(wdWithInTable) Then
.Bookmarks(bookMarkName).range.Tables(1).Delete
End If
.Bookmarks(bookMarkName).range.PasteExcelTable False, False, False
.Bookmarks.Add bookMarkName, wordRng 'reset range to its original positions
Dim paraFmt As ParagraphFormat
Set paraFmt = .Bookmarks(bookMarkName).range.Tables(1).range.ParagraphFormat
paraFmt.SpaceBefore = 0
paraFmt.SpaceBeforeAuto = False
paraFmt.SpaceAfter = 0
paraFmt.SpaceAfterAuto = False
paraFmt.LineSpacingRule = wdLineSpaceSingle
paraFmt.WidowControl = True
paraFmt.KeepWithNext = False
paraFmt.KeepTogether = False
paraFmt.PageBreakBefore = False
paraFmt.NoLineNumber = False
paraFmt.Hyphenation = True
paraFmt.OutlineLevel = wdOutlineLevelBodyText
paraFmt.CharacterUnitLeftIndent = 0
paraFmt.CharacterUnitRightIndent = 0
paraFmt.CharacterUnitFirstLineIndent = 0
paraFmt.LineUnitBefore = 0
paraFmt.LineUnitAfter = 0
paraFmt.MirrorIndents = False
paraFmt.TextboxTightWrap = wdTightNone
paraFmt.Alignment = wdAlignParagraphLeft
.Bookmarks(bookMarkName).range.Tables(1).AutoFitBehavior (wdAutoFitWindow)
End With
Try this sample piece of code for me please. I tested it From VBA Excel with different table types and it gave me satisfactory results. Please amend it whereever required... for example File Name / Sheet name etc...
Sub Sample()
Dim oWordApp As Object, oWordDoc As Object
Dim FlName As String
FlName = "C:\MyDoc.doc"
'~~> Establish an Word application object
On Error Resume Next
Set oWordApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set oWordApp = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0
oWordApp.Visible = True
Set oWordDoc = oWordApp.Documents.Open(FlName)
With oWordDoc
Dim xlRng As Range
Set xlRng = Sheets(1).Range("A1:D10")
xlRng.Copy
.Bookmarks("CostReport").Range.PasteSpecial Link:=False, _
Placement:=wdInLine, DisplayAsIcon:=False
End With
End Sub