Hi I am using the following code to copy values from an excel worksheet into a predefined table in word. The below works fine for 1 column, how can I get it to tranfer the data for all 5 columns? Thanks
Sub ExportData()
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim wdCell As Word.Cell
Dim i As Long
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim rnData As Range
Dim vaData As Variant
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("Sheet1")
With wsSheet
Set rnData = .Range("A1:E10")
End With
'Add the values in the range to a one-dimensional variant-array.
vaData = rnData.Value
'Here we instantiate the new object.
Set wdApp = New Word.Application
'Here the target document resides in the same folder as the workbook.
Set wdDoc = wdApp.Documents.Open(ThisWorkbook.Path & "\Test.doc")
'Import data to the first table and in the first column of a table in Microsoft Word.
For Each wdCell In wdDoc.Tables(1).Columns(1).Cells
i = i + 1
wdCell.Range.Text = vaData(i, 1)
Next wdCell
'Save and close the document.
With wdDoc
.Save
.Close
End With
'Close the hidden instance of Microsoft Word.
wdApp.Quit
'Release the external variables from the memory
Set wdDoc = Nothing
Set wdApp = Nothing
MsgBox "The data has been transfered to Test.doc, vbInformation"
End Sub
So this is a bit of a late answer, but try the following:
Add to declarations
Dim j As Long
Remove from declarations
Dim rnData As Range
Change
With wsSheet
Set rnData = .Range("A1:E10")
End With
'Add the values in the range to a one-dimensional variant-array.
vaData = rnData.Value
to
ReDim vaData(1 To 10, 1 To 5)
With wsSheet
vaData = .Range("A1:E10")
End With
And change
'Import data to the first table and in the first column of a table in Microsoft Word.
For Each wdCell In wdDoc.Tables(1).Columns(1).Cells
i = i + 1
wdCell.Range.Text = vaData(i, 1)
Next wdCell
to
For j = 1 To 5
i = 0
For Each wdCell In wdDoc.Tables(1).Columns(j).Cells
i = i + 1
wdCell.Range.Text = vaData(i, j)
Next wdCell
Next j
A correction
MsgBox "The data has been transferred to Test.doc", vbInformation
Related
Here is the sub I am using that splits loops through each tab and split them into multiple workbooks based on the user-specified column, "Manufacturer Name".
Sub SplitSheetIntoMultWkbksBasedOnCol(Col As String)
Dim objWorksheet As Excel.Worksheet
Dim nLastRow, nRow, nNextRow As Integer
Dim strColumnValue As String
Dim objDictionary As Object
Dim varColumnValues As Variant
Dim varColumnValue As Variant
Dim objExcelWorkbook As Excel.Workbook
Dim objSheet As Excel.Worksheet
Dim wsSheet As Worksheet
For Each wsSheet In Worksheets
If wsSheet.Name <> "Open" Then
wsSheet.Activate
Set objWorksheet = ActiveSheet
nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row
Set objDictionary = CreateObject("Scripting.Dictionary")
For nRow = 2 To nLastRow
'Get the specific Column
strColumnValue = objWorksheet.Range(Col & nRow).Value
If objDictionary.Exists(strColumnValue) = False Then
objDictionary.Add strColumnValue, 1
End If
Next
varColumnValues = objDictionary.Keys
For i = LBound(varColumnValues) To UBound(varColumnValues)
varColumnValue = varColumnValues(i)
'Create a new Excel workbook
Set objExcelWorkbook = Excel.Application.Workbooks.Add
Set objSheet = objExcelWorkbook.Sheets(1)
objSheet.Name = objWorksheet.Name
objWorksheet.Rows(1).EntireRow.Copy
objSheet.Activate
objSheet.Range("A1").Select
objSheet.Paste
For nRow = 2 To nLastRow
If CStr(objWorksheet.Range(Col & nRow).Value) = CStr(varColumnValue) Then
objWorksheet.Rows(nRow).EntireRow.Copy
nNextRow = objSheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row + 1
objSheet.Range("A" & nNextRow).Select
objSheet.Paste
objSheet.Columns("A:B").AutoFit
End If
Next
Next
End If
Next wsSheet
Workbooks("Open_Spreadsheet_Split.xlsm").Activate
Sheets(1).Activate
End Sub
This is ending up making way too many workbooks. So instead, for each tab, I want to copy the rows with the same Manufacturer to the same workbook.
EDIT: make sure headers from each source sheet are included on each destination sheet.
Try this out:
Sub SplitSheetIntoMultWkbksBasedOnCol(Col As String)
Dim wbSrc As Workbook, ws As Worksheet, wsTmp As Worksheet
Dim dict As Object, lastRow As Long, nRow As Long, v
Dim dictHeader As Object 'for tracking whether headers have been copied
Set dict = CreateObject("Scripting.Dictionary")
Set wbSrc = ActiveWorkbook
Application.ScreenUpdating = False
For Each ws In wbSrc.Worksheets
If ws.Name <> "Open" Then
Set dictHeader = CreateObject("Scripting.Dictionary") 'reset header-tracking dictionary
For nRow = 2 To ws.Cells(Rows.Count, "A").End(xlUp).Row
v = ws.Cells(nRow, Col).Value 'get the specific Column
'need a new workbook?
If Not dict.exists(v) Then
Set wsTmp = Application.Workbooks.Add(xlWBATWorksheet).Worksheets(1) 'add new workbook with one sheet
dict.Add v, wsTmp.Range("A1") 'add key and the first paste destination
End If
'first row from this sheet for this value of `v`?
If Not dictHeader.exists(v) Then
ws.Rows(1).Copy dict(v) 'copy headers from this sheet
Set dict(v) = dict(v).Offset(1, 0) 'set next paste position
dictHeader.Add v, True 'flag header as copied
End If
ws.Rows(nRow).Copy dict(v) 'copy the current row
Set dict(v) = dict(v).Offset(1, 0) 'set next paste position
Next nRow
End If 'not "open" sheet
Next ws
Workbooks("Open_Spreadsheet_Split.xlsm").Activate 'ThisWorkbook?
Sheets(1).Activate
End Sub
I'm working with the below code that copies and pastes a bunch of named ranges from Excel to Word as pictures which already saves me a bunch of time.
To really cap it off I'm wondering if there is a way to insert these images at set places within a word document?
Sub copypaste()
'Create new word document
Dim objWord As Object
Dim objDoc As Object
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set objDoc = objWord.documents.Add()
Dim intCounter As Integer
Dim rtarget As Word.Range
Dim wbBook As Workbook
Set wbBook = ActiveWorkbook
'Loop Through names
For intCounter = 1 To wbBook.Names.Count
Debug.Print wbBook.Names(intCounter)
With objDoc
Set rtarget = .Range(.Content.End - 1, .Content.End - 1)
'Insert page break if not first page
If intCounter > 1 Then rtarget.insertbreak Type:=wdPageBreak
'Write name to new page of word document
rtarget.Text = wbBook.Names(intCounter).Name & vbCr
'Copy data from named range
Range(wbBook.Names(intCounter)).Copy
Set rtarget = .Range(.Content.End - 1, .Content.End - 1)
rtarget.PasteSpecial , DataType:=wdPasteMetafilePicture
End With
Next intCounter
End Sub
I am using Office 365 on a Windows 10 64-bit pc.
I have a Word document with a table into which I want to copy elements from an Excel document. The elements are a) text from its cell, b) a hyperlink from its cell and c) images from a list of images.
The first two tasks are performed successfully by the following sub:
Sub ImportFromExcel()
Dim RowNo As Long, RowTarget As Long
Dim RowFirst As Long, RowLast As Long
Dim strContent As String, strLink As String, strDisplay As String
Dim xlAppl As New Excel.Application
Dim xlBook As New Excel.Workbook
Dim xlSheet As New Excel.Worksheet
Dim ExcelFileName As String
Dim tbl As Word.Table
On Error GoTo Finish
ExcelFileName = "C:\MyPath\MyExcelDoc.xlsm"
Set xlAppl = CreateObject("Excel.Application")
xlAppl.Application.Visible = False
xlAppl.Workbooks.Open ExcelFileName
Set xlBook = xlAppl.ActiveWorkbook
Set xlSheet = xlBook.Worksheets("Titan")
Set tbl = ActiveDocument.Tables(1)
RowFirst = 6: RowLast = 19
For RowNo = RowFirst To RowLast
RowTarget = RowNo - RowFirst + 1
strContent = xlSheet.Cells(RowNo, 5).Value
tbl.Cell(RowTarget, 1).Range.Text = strContent
strDisplay = xlSheet.Cells(RowNo, 3).Value
tbl.Cell(RowTarget, 3).Range.Text = strContent
strLink = xlSheet.Cells(RowNo, 3).Hyperlinks(1).Address
InsertHyperlinkInTable tbl, RowTarget, 3, strLink, strDisplay
' CopyImageFromExcelToWord xlSheet, RowTarget, tbl
Next RowNo
Finish:
xlAppl.ActiveWorkbook.Close False ' Word will not freeze at this point
xlAppl.Quit
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlAppl = Nothing
End Sub
I copy the hyperlink by reading its address and caption and then recreating it in Word.
Also from Word I can select a give image by way of its index using the first two active lines of the following sub:
Sub CopyImageFromExcelToWord(xlSheet As Excel.Worksheet, imgNo As Long, tbl As Word.Table)
Dim strId As String
' Syntax at https://learn.microsoft.com/en-us/office/vba/api/excel.worksheet.select
strId = "Picture " & CStr(2 * imgNo)
xlSheet.Shapes.Range(Array(strId)).Select
' Missing link !
With tbl.Cell(1, 4)
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.VerticalAlignment = wdCellAlignVerticalCenter
.Select
End With
Selection.PasteAndFormat (wdFormatOriginalFormatting)
End Sub
An image residing in the clipboard can be inserted into Word using the last six lines.
But I have not found out how to copy the image I selected in the Excel document to the clipboard with a Word macro.
Can this be done somehow?
Can the copying of the hyperlink be performed in a smarter way?
Try
Sub CopyImageFromExcelToWord(xlSheet As Excel.Worksheet, imgNo As Long, tbl As Word.Table)
Dim strId As String
' Syntax at https://learn.microsoft.com/en-us/office/vba/api/excel.worksheet.select
strId = "Picture " & CStr(2 * imgNo)
xlSheet.Shapes.Range(Array(strId)).Item(1).Copy
With tbl.Cell(1, 4)
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.VerticalAlignment = wdCellAlignVerticalCenter
.Range.PasteAndFormat wdFormatOriginalFormatting
End With
End Sub
I'm new to VBA and I'm having difficulty trying to insert comments from data that I have in Excel onto a Word document. I am trying to write the VBA in Word and want it to extract data from a separate spreadsheet
Sub ConvertCelltoWordComment()
Dim Rng As Range
Dim wApp As Object
Dim strValue As String
Dim xlapp As Object
Dim xlsheet As Object
Dim xlbook As Object
'Opens Excel'
Set xlapp = GetObject("C:\Users\eugenechang\Desktop\...xlsx")
If Err Then
Set xlapp = CreateObject("Excel.Application")
End If
On Error GoTo 0
Dim i As Integer
For i = 1 To 5
With xlsheet
strValue = ActiveSheet.Cells(i, 1).Offset(1, 0)
End With
'Insert comment into document'
ActiveDocument.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:="15"
ActiveDocument.Selection.GoTo What:=wdGoToLine, Which:=wdGoToRelative, Count:=5
ActiveDocument.Comments.Add Range:=Selection.Range, Text:=strValue
Next i
End Sub
I'm trying to get it to work, but it is giving me an error "Object not defined". I've tried setting up an object within the strValue line below "With xlsheet", but am hitting a wall. Any help??
You have not assigned anything to xlsheet - so this (by default) equates to Nothing.
Try setting xlSheet to something meaningful. The following is only an example:
For i = 1 To 5
Set xlsheet = xlbook.Worksheets(i) ' <--- example here
With xlsheet
strValue = .Cells(i, 1).Offset(1, 0) '<-- don't use ActiveSheet
End With
'Insert comment into document'
ActiveDocument.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:="15"
ActiveDocument.Selection.GoTo What:=wdGoToLine, Which:=wdGoToRelative, Count:=5
ActiveDocument.Comments.Add Range:=Selection.Range, Text:=strValue
Next I
An important note here is that you also have not set xlbook - you must also assign something meaningful to xlbook.
Add a couple DocVariables to your Word file and run the script below, from Excel.
Sub PushToWord()
Dim objWord As New Word.Application
Dim doc As Word.Document
Dim bkmk As Word.Bookmark
sWdFileName = Application.GetOpenFilename(, , , , False)
Set doc = objWord.Documents.Open(sWdFileName)
'On Error Resume Next
objWord.ActiveDocument.variables("FirstName").Value = Range("FirstName").Value
objWord.ActiveDocument.variables("LastName").Value = Range("LastName").Value
' etc., etc., etc.
objWord.ActiveDocument.Fields.Update
'On Error Resume Next
objWord.Visible = True
End Sub
This ended up writing comments from an Excel file. Obviously the names have been changed for privacy reasons. Please let me know if I can simplify this better.
Sub ConvertExceltoWordComment()
Dim wApp As Word.Application
Dim xlApp As Excel.Application
Dim PgNum As Integer
Dim LineNum As Integer
Dim objSelection As Word.Document
Dim strpgSearch As Long
Dim strlinSearch As Long
Dim myRange As Range
Dim XlLog As Excel.Worksheet
Dim RowCount As Long
'Opens Copied Word document'
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
If Err Then
Set xlApp = CreateObject("Excel.Application")
End If
On Error GoTo 0
Dim SaveDoc As Excel.Workbook
Set SaveDoc = xlApp.Workbooks.Open("FilePath.xlsm") 'Type filepath of document here'
Set XlLog = SaveDoc.Sheets("Worksheet_Name") 'Type Sheetname here'
RowCount = XlLog.Range("A1048576").End(xlUp).Row
If RowCount > 0 Then
Dim iTotalRows As Long
iTotalRows = XlLog.Rows.Count 'Get total rows in the table'
Dim txt As Variant
Dim iRows As Long
End If
Dim i As Integer
'Insert comment into Word document'
Set wApp = CreateObject("Word.Application")
wApp.Visible = True
If Err Then
Set wApp = CreateObject("Word.Application")
End If
Set objSelection = ActiveDocument
For iRows = 3 To iTotalRows
txt = XlLog.Cells(iRows, 8).Text 'Grabs appropriate comment text'
objSelection.Activate
objSelection.SelectAllEditableRanges
strpgSearch = XlLog.Cells(iRows, 2) 'Grabs appropriate Page number'
strlinSearch = XlLog.Cells(iRows, 3) 'Grabs appropriate Line number'
objSelection.ActiveWindow.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext,
Name:=strpgSearch
objSelection.ActiveWindow.Selection.GoTo What:=wdGoToLine, Which:=wdGoToRelative,
Count:=strlinSearch
Set myRange = ActiveWindow.Selection.Range
ActiveDocument.Comments.Add Range:=myRange, Text:=txt
Next iRows
Set xlApp = Nothing
Set SaveDoc = Nothing
Set XlLog = Nothing
Set objSelection = Nothing
Set myRange = Nothing
Set wApp = Nothing
SaveDoc.Close
End Sub
I want to select multiple columns by the column header in an Excel sheet, then copy these columns into a new workbook.
With the code below, Excel opens one book per column instead of pasting all of the selected columns into sheet1 of the new workbook.
I recorded a macro for this task, but the column header changes every time so I cannot depend on recorded macros.
Sub Colheadr()
Dim wsO As Worksheet
'Dim wsF As Worksheet....I comment out this line
Dim i As Integer
Application.ScreenUpdating = False
Set wsO = ActiveSheet
'Set wsF = Worksheets("Final").....I comment out this line
myColumns = Array("Facility", "Last Name", "First Name", "MRN", "adm date")
With wsO.Range("A1:W1")
For i = 0 To UBound(myColumns)
On Error Resume Next
.Find(myColumns(i)).EntireColumn.Copy
Workbook.Add
ActiveSheet.Paste
'Destination:=wsF.Cells(1, i + 1)...I comment out this line
Err.Clear
Next i
End With
Set wsO = Nothing
Set wsF = Nothing
Application.ScreenUpdating = True
End Sub
Try this out:
Public Sub CopyBetweenBooks()
Dim myCollection As Collection
Dim myIterator As Variant
Dim myRng As Range
Dim xlcell As Variant
Dim otherwb As Workbook
Dim mywb As Workbook
Dim colCounter As Integer
Set mywb = ThisWorkbook
Set myCollection = New Collection
'Create a collection of header names to search through
myCollection.Add ("Header1")
myCollection.Add ("Header2")
myCollection.Add ("Header3")
'Where to search, this is the header
Set myRng = ActiveSheet.Range("A1:W1")
Set otherwb = Workbooks.Add
colCounter = 0
For Each xlcell In myRng.Cells ' look through each cell in your header
For Each myIterator In myCollection ' look in each item in the collection
If myIterator = xlcell.Value Then ' when the header matches what you are looking for
colCounter = colCounter + 1 ' creating a column index for the new workbook
mywb.ActiveSheet.Columns(xlcell.Column).Copy
otherwb.ActiveSheet.Columns(colCounter).Select
otherwb.ActiveSheet.Paste
End If
Next
Next
End Sub
I also have the same problem 3 years later in 2019. Ryan Wildry was right. Instead of collection data type use array to maintain user defined column sequence. That's why I am referring Ryan Wildry's solution with additional lines.
Public Sub CopyBetweenBooks()
Dim myCollection(1 To 3) As String
Dim myIterator As Variant
Dim myRng As Range
Dim xlcell As Variant
Dim otherwb As Workbook
Dim mywb As Workbook
Dim colCounter As Integer
Set mywb = ThisWorkbook
'Create an array of header names to search through
myCollection(1) ="Header1"
myCollection(2) ="Header2"
myCollection(3) ="Header3"
'Where to search, this is the header
Set myRng = ActiveSheet.Range("A1:W1")
Set otherwb = Workbooks.Add
colCounter = 0
For i = LBound(myCollection) To UBound(myCollection)
For Each xlcell In myRng.Cells ' look through each cell in your header
If myCollection(i) = xlcell.Value Then ' when the header matches what you are looking for
colCounter = colCounter + 1 ' creating a column index for the new workbook
mywb.ActiveSheet.Columns(xlcell.Column).Copy
otherwb.ActiveSheet.Columns(colCounter).Select
otherwb.ActiveSheet.Paste
End If
Next
Next
Next
End Sub