I create multiple tables in word and populate them with data from an excel file.
The coding is done in Excel VBA. I use the Range object in the word document to identify where to insert the next table.
So i add a table, populate it and insert a new row below it.
I then store the end of the current table range as a reference for adding the next table. So far no problem.
But when I insert a lot of data into a table and then change the width of the columns, this takes some time in word. So the reference I stored before might not be valid any more once I want to create the next table.
The whole document changed in the meantime and the position I stored doesn't exist any more. Is there a way around this? Currently I wait for 2 Seconds to not get the error.
Public Function PrintWord(Word, Document, Start As Integer) As Integer
Dim intNoOfRows
Dim intNoOfColumns
intNoOfRows = 7
intNoOfColumns = 2
x = Start
Set objRange = Document.Range(x, x)
Set objTable = Document.Tables.Add(objRange, intNoOfRows, intNoOfColumns)
objTable.Borders.Enable = True
objTable.Cell(1, 1) = [...] ' This is where I populate the table and change the width etc.
Dim y As Integer
Application.Wait (Now + TimeValue("0:00:02")) ' if I wait here, everything works, if not the Range for the next table is some times not valid
y = objTable.Range.End + 1 ' Store the end of the table as a reference for the next one
Document.Range(x, y).ParagraphFormat.SpaceAfter = 3
objTable.Columns(1).PreferredWidthType = 3 ' wdPreferredWidthPoints
objTable.Columns(1).PreferredWidth = Word.CentimetersToPoints(3.5)
objTable.Columns(2).PreferredWidthType = 3 ' wdPreferredWidthPoints
objTable.Columns(2).PreferredWidth = Word.CentimetersToPoints(13)
objTable.Select
Word.Selection.MoveDown Unit:=5, count:=1 ' Move below table
Word.Selection.TypeParagraph
PrintWord = y ' Returns the position for the next Table
End Function
Related
I am trying to build an Access db of inspection data for mass manufactured plastic parts from a bunch of Excel sheets, which come from different sources.
I am doing this with two Access files: one as the front end/UI (Forms and Macros), and one as the back end (Tables containing the desired data).
My process:
Use front end Access Form to open the msoFileDialogFilePicker and select an Excel sheet of data to get read into my back end Access Table. The Table where the data is stored in the back end file depends on radio buttons selections in the front end file Form.
Macro reads data from Excel sheet, transposes data, and stores it in a new dumpSheet at the end of the original data file. Each row in this dumpSheet is effectively its own record in the corresponding back end Access table. Data gets read into back end Access Tables using DAO.Database and DAO.Recordset.
Repeat with new inspection data as it comes in every two weeks.
The inspection data comes from different sources, but it can be for the same plastic part. This combination of company + part dictates which fields are of interest to be read into the recordset. For example, all of these combinations would have different fields (each combination has its own table), but there is new inspection data for each combination every two weeks (hence the need for a db):
Company X + Part A
Company X + Part B
Company Y + Part A
Company Y + Part B
Here is a general look at how I'm setting this up in the Access front end Form Macro (where the fields listed in the Do While Loop are for one specific Company + Part combination:
Set excelTemp = New Excel.Application
excelTemp.Visible = True
excelTemp.DisplayAlerts = True
Set trExcelWB = excelTemp.Workbooks.Open("myExcelData.xlsx") 'Picked from msoDialogFilePicker
Dim ws As Worksheet
Set ws = trExcelWB.Sheets(Sheets.Count)
Dim dbDump As DAO.Database
Set dbDump = DBEngine.Workspaces(0).OpenDatabase("backend-database.accdb")
Dim dumpTable as String
dumpTable = "myTableForDataInBackEndDB"
Dim tdf As DAO.TableDef
Set tdf = dbDump.TableDefs(dumpTable)
Dim rst As DAO.Recordset
Set rst = dbDump.OpenRecordset(Name:=dumpTable)
With rst
.AddNew
Dim n as Integer
n = 2
Do While Len(ws.Cells(n,5).Value) > 0 '5th column of dumpSheet stores unique part IDs and governs end of my dataset on the dumpSheet
.AddNew
![Date of Inspection] = ws.Cells(n, 2).Value
![Date of Production] = ws.Cells(n, 3).Value
![LOT] = ws.Cells(n, 4).Value
![Serial] = ws.Cells(n, 5).Value
![Part] = ws.Cells(n, 6).Value
![Depth] = ws.Cells(n, 7).Value
![Wall thickness] = ws.Cells(n, 8).Value
.Update
n = n + 1
Loop
Which works in the case where I have:
Date of Inspection
Date of Production
LOT
Serial
Part
Depth
Wall Thickness
As my field names. These are my headers in only one case of many.
I would like something like this in my Do While Loop:
Do While Len(ws.Cells(n,5).Value) > 0
Dim col as Integer
For col = 2 To ws.UsedRange.Columns.Count
.AddNew
![dbDump.TableDefs(dumpTable).Fields(col - 1).Name] = ws.Cells(n, col).Value
Next col
.Update
n = n + 1
Loop
I get an Error
"Item not found in Collection".
I'm confused because dbDump.TableDefs(dumpTable).Fields(col - 1).Name on its own gives me the name of the field I want as a string, but I cannot figure out how to call it in the dbDump from this code.
I've looked and can't figure out how to loop through field names via index and not name.
I'm writing some VBA code for a user form. The values are selected in a listbox on the left (LB_Participants). Then "select" is pressed and the values are copied to a listbox on the right (LB_Output). I then want VBA to go through all these items seperatly in the LB_Output and look up other associated data from another worksheet. Problem I'm having is that somethimes the values are not selected. I check it with a messagebox and from time to time its blank. Then no associated data can be retrieved ofcourse.
Before starting to fill in the userform, if I just click once on LB_Output (even without selecting any value) I don't have this problem. Many people will be using the userform so I don't want to explain tot them that they have to click first on the listbox before continuing... Is there something I'm not doing right?
Blank Msgbox
Dim ListCount As Integer
Dim z As Integer
ListCount = UserForm2.LB_Output.ListCount
For z = 0 To ListCount - 1
UserForm2.LB_Output.Selected(z) = True
TextString = UserForm2.LB_Output.Value
MsgBox (TextString)
'Split Participants into seperate names and copy them to data sheet
WArray() = Split(TextString, ";")
For Counter = LBound(WArray) To UBound(WArray)
Dim LRNames As Integer
If IsEmpty(Sheets("Data").Range("A1")) = True Then
LRNames = 0
Else
LRNames = Sheets("Data").Range("A" & Application.Rows.Count).End(xlUp).Row
End If
Strg = WArray(Counter)
Sheets("Data").Cells(LRNames + 1, 1) = Trim(Strg)
Next Counter
Next z
Not sure I understand, but think you want to loop through all the items in LB_Output and process them regardless if selected or not - all the selection was done in the other listbox and those items moved to LB_Output.
This does not explicitly select each item, simply gets data from it.
For z = 0 to UserForm2.LB_Output.Listcount -1
' If you want to select the item to show 'progress' through the list,
' uncomment ...
' LB_Output.listindex = z
' The next line will still work as is
TextString = UserForm2.LB_Output.List(z)
'// Do processing with this item
Next
There are around 150 tables in my Word file. Each table has six rows and two columns.
I need to copy the first and last row values from each table to an Excel sheet.
The first row will have my table id and last row data is Pass/Fail.
In general, you should try to post the code that you tried so far so we can help you debug and get to the final answer:
Summarize the problem
Describe what you’ve tried
Show some code
When appropriate, share the minimum amount of code others need to reproduce your problem (also called a minimum, reproducible example)
But, I'll try to give you some code to get going.
If it helps you, please consider to mark it as the correct answer :)
Please try the following code:
Sub extract_word_table_values_to_excel()
Dim word_app As Object, temp_doc As Object, word_doc As Object
'Set word_app = CreateObject("Word.Application")
ActiveSheet.Calculate
word_path = Range("Word_path")
'Place your word doc path here in the named range on the sheet
temp = Split(word_path, "\")
word_name = temp(UBound(temp))
Set word_doc = GetObject(word_path)
Set word_app = word_doc.Application
word_app.Visible = True
word_doc.Activate
excel_row = 1
On Error Resume Next
Dim word_table As Word.Table 'Or As variant
For Each word_table In word_doc.Tables
Err.Clear
For i = 1 To word_table.Rows.Count Step word_table.Rows.Count - 1
'Step count minus 1 means only first and last row are looped
For j = 1 To word_table.Columns.Count
part = word_table.Rows(i).Cells(j).Range.Text
part = Left(part, Len(part) - 1)
part = Replace(part, vbNewLine, "")
'MsgBox part
Sheet2.Cells(excel_row, j).Value = part
Next j
excel_row = excel_row + 1
Next i
excel_row = excel_row + 1 'Leave row between tables
Next word_table
MsgBox "done"
word_doc.Save
'word_app.Quit
Set word_doc = Nothing
Set word_app = Nothing
End Sub
Please leave a comment if you have a question.
I have a query that returns something like this:
1 2 3 4 5 6 7
A. B. C. D. E. F. G.
Etc...
Etc...
N rows
I store the query on a dataset. Then I create the Excel file using something like this:
Sql=“select * from table”
Dim cmd As New SqlDataAdapter(Sql, con)
Dim ds As New DataSet
cmd.Fill(ds)
For i=0 To Tables(0).Rows.Count - 1
For x=0 To ds.Tables(0).Columns.Count - 1
ExcelFile.Cells(i+1;x+1)=ds.Tables(0).Rows(i).Item(j)
Next
Next
The code works fine except that I need to write also columns headers name (1,2,3,4,etc.) My first que question is how can I add the headers?
And the main problem... the query sometimes is going to return more than 80k results, so following the for loop logic my code is going to run 80k times for every column (in this case 7 times) which is going to give me a slow result.
There is another fast way to fill and Excel file? Or this is the best way to do it?
You have access to the ColumnName property of each Column in your DataTable. For example, to just add the headers with as little modification of your code as possible, you could just do this:
'Write ColumnName to the corresponding cell in row 1
For x=0 To ds.Tables(0).Columns.Count - 1
ExcelFile.Cells(1, x+1) = ds.Tables(0).Columns(x).ColumnName
Next
'Modded to start at the second row and fix index variable
For i=1 To Tables(0).Rows.Count - 1
For x=0 To ds.Tables(0).Columns.Count - 1
ExcelFile.Cells(i+1, x+1) = ds.Tables(0).Rows(i).Item(x)
Next
Next
You are right to be concerned about the performance of this, though. The number one rule of Excel automation is to actually interact with Excel as little as possible, because each interaction is very expensive.
Assuming you are using regular Office Interop, you should build a 2-dimensional array representing the values from your query. You then find an equivalent size range in your worksheet, and set the value of that range to the array. This way you've cut many thousands of interactions to just one.
Dim rowCount = ds.Tables(0).Rows.Count
Dim colCount = ds.Tables(0).Columns.Count
Dim ws = ExcelFile
Dim valueSet(,) As Object
ReDim valueSet(rowCount - 1, colCount - 1)
For row = 0 To rowCount - 1
For col = 0 To colCount - 1
valueSet(row, col) = ds.Tables(0).Rows(row).Item(col)
Next
Next
'Set the entire set of values in a single operation
ws.Range(ws.Cells(1, 0), ws.Cells(rowCount, colCount).Value = valueSet
Also, if you actually are using Excel Interop or a wrapper around it like NetOffice, you should look into EPPlus and see if it does what you need. It's a helper library that works with OfficeOpenXML and doesn't even require Excel to be installed.
I use the following:
Dim sSql As String
Dim tbl As ListObject
'Declare a Connection object
Dim cnDB As New ADODB.Connection
'Declare a Recordset Object
Dim rs As ADODB.Recordset
' Housekeeping, set the connection strings
Set cnn = New ADODB.Connection
cnn.Provider = "MSDASQL"
cnn.CommandTimeout = 100
Set tbl = ActiveSheet.ListObjects("Lookup")
With tbl.DataBodyRange
If .Rows.Count > 1 Then
.Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
End If
End With
' Connect to the database and paste new data
cnn.ConnectionString = "driver={};server={};uid={};pwd={};database={}"
sSql = "SELECT BLAH BLAH "
cnn.Open
Set rs = cnn.Execute(sSql)
ThisWorkbook.Worksheets("Lookup").Range("A2").CopyFromRecordset rs
cnn.Close
I have an excel table, with one of the columns is named ID.
I am trying to do a search of that column to find what row contains a certain value. I have tried many different commands, (all of which check our with the editor's syntax checking), but I cannot figure out how to get it to work.
My line of code that I am trying to make work is toward the bottom of the program and is foundrow = summObj.ListColumns("ID")...
Here is my code so far:
Private Sub Reload_Click()
'Routine to move data to table from Molding Table
'Check to not overwrite current records but add new ones.
Dim summObj As ListObject
Dim moldObj As ListObject
Dim I, X As Integer
Dim summObjRows As Integer
Dim moldObjRows As Integer
Dim key As String
Dim foundrow As Integer
' Get the table reference
Set summObj = Worksheets("Summary").ListObjects("SummaryTable")
Set moldObj = Worksheets("MoldingData").ListObjects("MoldingTable")
summObjRows = summObj.ListRows.Count
moldObjRows = moldObj.ListRows.Count
'Check if table is empty
If summObjRows = 0 Then
'Set up the first row
summObj.ListRows.Add
summObj.ListColumns("ID").DataBodyRange(1) = "New"
End If
X = 1
For I = 1 To moldObj.ListRows.Count
key = moldObj.DataBodyRange(I, moldObj.ListColumns("ID").DataBodyRange.Column) & "," & moldObj.DataBodyRange(I, moldObj.ListColumns("6-Way").DataBodyRange.Column)
If moldObj.DataBodyRange(I, moldObj.ListColumns("Volume").DataBodyRange.Column) <> "" Then
If Not (key = summObj.ListColumns("ID").DataBodyRange(X)) Then
'Insert row into Summary Table unless this is the first row in a blank table.
If Not summObj.ListColumns("ID").DataBodyRange(X) = "New" Then
summObj.ListRows.Add (X)
End If
summObj.ListColumns("ID").DataBodyRange(X) = key
summObj.ListColumns("Volume").DataBodyRange(X) = moldObj.ListColumns("Volume").DataBodyRange(I)
summObj.ListColumns("Item Name").DataBodyRange(X) = moldObj.ListColumns("Item Name").DataBodyRange(I)
summObj.ListColumns("Data1").DataBodyRange(X) = moldObj.ListColumns("Data1").DataBodyRange(I)
summObj.ListColumns("Data2").DataBodyRange(X) = moldObj.ListColumns("Data2").DataBodyRange(I)
Else
summObj.ListColumns("Volume").DataBodyRange(X) = moldObj.ListColumns("Volume").DataBodyRange(I)
summObj.ListColumns("Data2").DataBodyRange(X) = moldObj.ListColumns("Data2").DataBodyRange(I)
End If
X = X + 1
Else
'Check it to see if it is in Summary, and if so remove it
foundrow = summObj.ListColumns("ID").DataBodyRange.Find(key).Row
End If
Next I
End Sub
Thanks for helping me to solve this one.
Rich
I made a small change to the line in question.
I removed the (x) from the line.
Now what happens is that if the string is found in the column, then the row number is put in foundrow. If the string is not in the column, then i get the runtime error '91'
Any additional thoughts?
Rich