Thank you in advance, I need help in completing the below code, the code currently works to add the number of rows in the Table(3) of my word template as per the available rows in excel table, the word template have one row to begin with.
How can I pass the value from excel table range Set Rng = wsSheet.Range("A2:C" & lastrow)
Option Explicit
Sub CopyToWordTemplate()
Const stWordDocument As String = "TemplateSD.docm"
Dim intNoOfRows
Dim objWord As Word.Application
Dim objDoc As Word.Document
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim lRow, i, lastrow, lastcol As Long
Dim vaData As Variant
Dim Rng As Range
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("Transmittal")
lastrow = wsSheet.Range("A2").End(xlDown).Row
lastcol = wsSheet.Range("C2").End(xlToRight).Column
Set Rng = wsSheet.Range("A2:C" & lastrow)
Rng.ClearContents
Copy_Criteria_Text
lRow = wsSheet.Range("A2").End(xlDown).Row
intNoOfRows = lRow - 1
Set objWord = New Word.Application
objWord.Visible = True
Set objDoc = objWord.Documents.Open("\\Dn71\dn071\DOCUMENT CONTROL\Common\X-
Templates\Document Control\" & stWordDocument)
With objWord.ActiveDocument
.Bookmarks("Description").Range.Text = wsSheet.Range("D1").Value
.Bookmarks("RevNumber").Range.Text = "C" & wsSheet.Range("E1").Value
.Bookmarks("SubmittalNumber").Range.Text = "DN071-P02-CRC-GEN-PMT-SDA-" & wsSheet.Range("F1").Value
End With
For i = 2 To intNoOfRows
objDoc.Tables(3).Rows.Add
Next
Set objWord = Nothing
End Sub
Related
I am starting out with VBA and have encountered issues with the following code. Ultimately I just want to store the row for use later. Can someone assist me please?
Sub UpdateQuote()
Dim wb As Workbook
Dim ws As Worksheet
Dim FoundCell As Range
Dim FoundRow As Range
Dim FindValue As String
Set wb = ActiveWorkbook
Set ws = ActiveSheet
FindValue = Sheet24.Range("D3")
Set FoundCell = Sheet20.Range("A:A").Find(What:=FindValue)
Set FoundRow = FoundCell.Row
Application.ScreenUpdating = False
MsgBox FoundRow
End Sub
I'm struggling trying to export a Word table to an Excel sheet, while preserving the number formatting. My code works as shown below, but the part I commented out is how I'm currently trying to do it (and failing). Could someone point out what I'm doing wrong?
Public Sub CopyTableToExcel()
Dim xlApp As Excel.Application
Dim xlwb As Excel.Workbook
Dim doc As Word.Document
Dim tbl As Word.Table
Dim lastRow As Long, lastColumn As Integer
Dim tblRange As Word.Range
Dim excelRange As Excel.Range
Set doc = ThisDocument
Set xlApp = CreateObject("Excel.Application")
Set xlwb = xlApp.Workbooks.Add 'Create new workbook
Set tbl = doc.Tables(2)
With tbl:
lastRow = .Rows.Count
lastColumn = .Columns.Count
Set tblRange = .Cell(1, 1).Range
tblRange.End = .Cell(lastRow, lastColumn).Range.End
tblRange.Copy
xlwb.Worksheets(1).Paste
'This part doesn't work, but I'm trying to do something like this:
'Set excelRange = xlwb.Worksheets("Sheet1").Range("A1")
'excelRange.PasteSpecial (xlPasteValuesAndNumberFormats)
End With
Set xlwb = Nothing
Set xlApp = Nothing
Set tbl = Nothing
Set doc = Nothing
End Sub
Thanks for your help!
I am creating a macro that is supposed to separate and add new worksheets based off one worksheet with all the data in it.
It won't run and I'm not sure why.
My code keeps hitting a Run Time Error '9': Script out of range. I'm not sure if it has something to do with the first sub or the second sub.
The error occurs on line 16:
Set wsMain = wbMain.Sheets("MAIN")
First sub:
Option Explicit
Sub main()
Dim wbMain As Workbook
Dim wsMain As Worksheet
Dim rngMain As Range
Dim RngCategoryOne As Range
Dim RngCategoryTwo As Range
Dim RngCategoryThree As Range
Dim RngCategoryFour As Range
Dim RngCategoryFive As Range
Dim RngCategorySix As Range
Dim rng As Range
Dim SheetNames As Variant
Dim str As Variant
Set wbMain = ActiveWorkbook
Set wsMain = wbMain.Sheets("MAIN")
Set rngMain = wsMain.Range("F2:F3000")
For Each rng In rngMain
Select Case rng
Case "HO NMX_AMO", "HO NMX_EUR", "WTI NMX", "DIESEL OHR EIA_AMO"
If RngCategoryOne Is Nothing Then
Set RngCategoryOne = rng
Else
Set RngCategoryOne = Union(rng, RngCategoryOne)
End If
Case "WTI NMX_AMO"
If RngCategoryTwo Is Nothing Then
Set RngCategoryTwo = rng
Else
Set RngCategoryTwo = Union(rng, RngCategoryTwo)
End If
Case "NG HH NMX"
If RngCategoryThree Is Nothing Then
Set RngCategoryThree = rng
Else
Set RngCategoryThree = Union(rng, RngCategoryThree)
End If
Case "RBOB NMX_EUR", "RBOB NMX_AMO"
If RngCategoryFour Is Nothing Then
Set RngCategoryFour = rng
Else
Set RngCategoryFour = Union(rng, RngCategoryFour)
End If
Case "GO ICE_AMO"
If RngCategoryFive Is Nothing Then
Set RngCategoryFive = rng
Else
Set RngCategoryFive = Union(rng, RngCategoryFive)
End If
Case "C3 CONW INW OPIS_APO, C3 MBEL TET OPIS_APO"
If RngCategorySix Is Nothing Then
Set RngCategorySix = rng
Else
Set RngCategorySix = Union(rng, RngCategorySix)
SheetNames = Array("AT, LB, LC, AS", "AO", "LN", "RF, RA", "ULA2", "8K, BO")
For Each str In SheetNames
Call AddNewWorksheet(wbMain, str)
Next str
wbMain.Sheets("AT, LB, LC, AS").Range("A1:A" & RngCategoryOne.Count) = RngCategoryOne.Value
wbMain.Sheets("AO").Range("A1:A" & RngCategoryTwo.Count) = RngCategoryTwo.Value
wbMain.Sheets("LN").Range("A1:A" & RngCategoryThree.Count) = RngCategoryThree.Value
wbMain.Sheets("RF, RA").Range("A1:A" & RngCategoryFour.Count) = RngCategoryFour.Value
wbMain.Sheets("ULA2").Range("A1:A" & RngCategoryFive.Count) = RngCategoryFive.Value
wbMain.Sheets("8K, BO").Range("A1:A" & RngCategorySix.Count) = RngCategorySix.Value
wsMain.Activate
wsMain.Range("A1").Select
End If
End Select
Next
End Sub
Second Sub:
Sub AddNewWorksheet(ByRef wb As Workbook, ByVal wsName As Variant)
With wb.Sheets
.Add(after:=wb.Sheets(.Count)).Name = wsName
End With
End Sub
Am trying to programme a lookup across 2 workbook with workbook path and name linked to cell for dynamic updates ... my current code is getting an error:
"object does not support property or method" on line 29 set lookfor
Can you help me resolve this?
Sub Lookup()
Dim wb1 As String, wb2 As String
Dim wbook1 As Workbook, wbook2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lookFor As Range
Dim srchRange As Range
Dim wb1name As String, wb2name As String
Dim wb1path As String, wb2path As String
Dim sFormulaPre As String, sFormulaSuff As String
Dim rowstart As Long
wb1name = Workbooks("r.xlsm").Sheets("Front sheet").Range("B3").Text
wb2name = Workbooks("r.xlsm").Sheets("Front sheet").Range("AA1").Text
wb1path = Workbooks("r.xlsm").Sheets("Front sheet").Range("AB1").Text
wb2path = Workbooks("r.xlsm").Sheets("Front sheet").Range("AB1").Text
wb1 = wb1path & wb1name
wb2 = wb2path & wb1name
Set wbook1 = Workbooks(wb1name)
Set wbook2 = Workbooks(wb2name)
Set ws1 = wbook1.Sheets("DATA1")
Set ws2 = wbook2.Sheets("DATA")
Set lookFor = wbook2.ws2.Range("$G:$J")
Set srchRange = wbook1.ws1.Range("$A:$E")
Dim bIsEmpty As Boolean
sFormulaPre = "vlookup(D"
sFormulaSuff = ",srchRange, 2,FALSE)"
If IsEmpty(Workbooks("r.xlsm").Sheets("Front sheet").Range("Y1")) = False Then
With wbook2.ws2
rowstart = .Cells(G, 11)
MsgBox sFormulaPre & rowstart & sFormulaSuff
End With
ElseIf IsEmpty(Workbooks("Rates, percentages calculator.xlsm").Sheets("Front sheet").Range("Y1")) = True Then
bIsEmpty = True
End If
End Sub
You already Set your ws2 worksheet object to wbook2, with this line Set ws2 = wbook2.Sheets("DATA")
so change your :
Set lookFor = wbook2.ws2.Range("$G:$J")
to:
Set lookFor = ws2.Range("$G:$J")
The same goes for:
Set srchRange = wbook1.ws1.Range("$A:$E")
should be:
Set srchRange = ws1.Range("$A:$E")
And, change With wbook2.ws2
to: With ws2
I am making a VBA machine that takes a Word document and searches it for terms in an Excel file, then copies each sentence with the term and pastes it in the Excel sheet. I have kind of cobbled together two different pieces of code that search a Word document for a list of words from another Word document, and one that copies every sentence that uses a given word. Here is my code:
Sub thesearchmacro()
Dim excelfile As Object
Dim excelsheet As Object
Dim worddoc As Document
Dim searchcell As Range
Dim destcol As Integer
Dim destrow As Integer
Dim searchterms As Range
Dim documentrange As Range
Set documentrange = ActiveDocument.Range
Set excelfile = CreateObject("Excel.Application")
Set excelsheet = excelfile.workbooks.Open("U:\filepath\searchmachine.xlsm")
Set searchterms = excelsheet.Worksheets("Data").Range("B2:GX2")
destcol = 2
For Each searchcell In searchterms.Cells
destrow = 3
With documentrange.Find
Do
.Text = searchcell
documentrange.Expand unit:=wdSentence
documentrange.Copy
documentrange.Collapse wdCollapseEnd
excelsheet.Cells(destrow, destcol).Paste
destrow = destrow + 1
Loop While .Found
destcol = destcol + 1
End With
Next
End Sub
Whenever I run this:
Set searchterms = excelsheet.Worksheets("Data").Range("B2:GX2")
comes back with a type mismatch error.
*edit: missed a copy
added findwindow's suggestion
This is what worked in the end. If you are trying to replicate it feel free to ask me anything.
Sub thesearchmacro()
Dim excelfile As Object
Dim excelsheet As Object
Dim worddoc As Document
Dim searchcell As Object
Dim destcol As Integer
Dim destrow As Integer
Dim destcell as Object
Dim searchterms As Object
Dim documentrange As Range
Set documentrange = ActiveDocument.Range
Set excelfile = CreateObject("Excel.Application")
Set excelsheet = excelfile.workbooks.Open("U:\filepath\searchmachine.xlsm")
Set searchterms = excelsheet.Worksheets("Data").Range("B2:GX2")
destcol = 2
For Each searchcell In searchterms.Cells
destrow = 3
With documentrange.Find
Do
.Text = searchcell
.execute
If .Found Then
documentrange.Expand unit:=wdSentence
excelsheet.Sheets("Data").Cells(destrow, destcol) = documentrange
documentrange.Collapse wdCollapseEnd
destrow = destrow + 1
Loop While .Found
destcol = destcol + 1
End With
Next
End Sub
Word.Range and Excel.Range are different types.
If you are happy to add a reference to Excel to your project, do that and replace all Ranges with either Word.Range or Excel.Range as appropriate.
Otherwise declare all Excel types as Objects.