I am writing a program that is supposed to merge several word documents into one keeping the formatting of each document. After some research on the web wrote a version that is supposed to work, which is the following:
Public Sub processmodulestest(ByVal id As Integer)
Dim oMissing = System.Reflection.Missing.Value
Dim oFalse = False
Dim oTrue = True
Dim fileDirectory = "C:\<file-path>\MOD-TEST\"
Dim wrdApp As New Word.Application
Dim destDoc As Word.Document 'destination doc
Dim docfile As Word.Document 'tmp doc to paste
destDoc = wrdApp.Documents.Add
'docNew.PageSetup.TopMargin = wrdApp.InchesToPoints(1.0F)
'docNew.PageSetup.BottomMargin = wrdApp.InchesToPoints(0.0F)
Dim wordFiles() As String = Directory.GetFiles(fileDirectory, "*.doc")
wrdApp.Options.Pagination = False
wrdApp.ActiveWindow.View.ShowAll = True
For Each el As String In wordFiles
docfile = wrdApp.Documents.Open(el, False, False)
wrdApp.Selection.WholeStory()
wrdApp.Selection.Copy()
wrdApp.ActiveWindow.Close(Word.WdSaveOptions.wdDoNotSaveChanges)
destDoc.Activate()
wrdApp.Selection.PasteAndFormat(Word.WdRecoveryType.wdFormatOriginalFormatting)
wrdApp.Selection.InsertBreak(Word.WdBreakType.wdPageBreak)
Next
wrdApp.Visible = True
End Sub
I get the following Error:
An unhandled exception of type'System.Runtime.InteropServices.COMException'
HRESULT: 0x80010108 (RPC_E_DISCONNECTED)) The object invoked has disconnected from its clients.
referring to the following line:
destDoc.Activate()
I read that this should be because the code uses an unqualified method on an Office instance that has been ended, but i can't understand how to fix it
I'm not sure how to do it in VB.NET, but the VBA code below will merge all Word documents into one single consolidated Word document.
Appending multiple Word docs into a single Word doc
Sub Foo()
Dim i As Long
Dim MyName As String, MyPath As String
Application.ScreenUpdating = False
Documents.Add
MyPath = "C:\Documents and Settings\Excel\Desktop\Word Files\" ' <= change this as necessary
MyName = Dir$(MyPath & "*.doc") ' not *.* if you just want doc files
Do While MyName <> ""
If InStr(MyName, "~") = 0 Then
Selection.InsertFile _
FileName:="""" & MyPath & MyName & """", _
ConfirmConversions:=False, Link:=False, _
Attachment:=False
Selection.InsertBreak Type:=wdPageBreak
End If
MyName = Dir ' gets the next doc file in the directory
Loop
End Sub
Related
I'm trying to write a macro that will generate a Microsoft Word 'report' from an Excel file. I want for the macro to navigate to bookmarks in a Word template for the report, and insert at each certain content or a chart from the native Excel file. The macro works when running in piecemeal, but altogether fails to execute, with Excel repeating over and over that "[It] is waiting for another application to complete an OLE action."
To clarify also, the macro first clears a certain 'data dump' region in the workbook (its native file) and repopulates it with new data from a specified file. This file (its location path) and the various 'target row' and 'identifier' variables you see in the code are inputted by the user to a sort of interface (just a worksheet in the native workbook), where each is labeled manually as a (named) range to be easily fed into to be used by the code. The macro then creates the report by going through the different sheets of the workbook, copying certain content, and turning to Word to paste the copied content at template locations indicated by bookmarks.
I'm completely perplexed by the 'OLE error'. Any ideas about this/the code otherwise? Please share. Thanks for your help!
Sub GenerateReport()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim myWorkbook As Excel.Workbook
Set myWorkbook = ThisWorkbook
Dim myWorksheet As Excel.Worksheet
Set myWorksheet = myWorkbook.Sheets("Sheet1")
Dim myWorksheet2 As Excel.Worksheet
Set myWorksheet2 = myWorkbook.Sheets("Sheet2")
Dim myWorksheet3 As Excel.Worksheet
Set myWorksheet3 = myWorkbook.Sheets("Sheet3")
Dim FileName As String
FileName = myWorksheet.Range("FileName")
Dim FilePath As String
FilePath = myWorksheet.Range("FilePath")
Dim TargetSheetName As String
TargetSheetName = myWorksheet.Range("TargetSheetName")
Dim PasteSheetName As String
PasteSheetName = myWorksheet.Range("PasteSheetName")
Dim Identifier As String
Identifier = myWorksheet.Range("Identifier")
Dim Identifier2 As String
Identifier2 = myWorksheet.Range("Identifier2")
Dim TargetRow As String
TargetRow = myWorksheet.Range("TargetRow")
Dim TargetRow2 As String
TargetRow2 = myWorksheet.Range("TargetRow2")
Dim PasteIdentifier As String
PasteIdentifier = myWorksheet.Range("PasteIdentifier")
Dim PasteIdentifier2 As String
PasteIdentifier2 = myWorksheet.Range("PasteIdentifier2")
Dim PasteTargetRow As String
PasteTargetRow = myWorksheet.Range("PasteTargetRow")
Dim PasteTargetRow2 As String
PasteTargetRow2 = myWorksheet.Range("PasteTargetRow2")
Dim Text As String
Text = myWorksheet.Range("Text")
Dim Text2 As String
Text2 = myWorksheet.Range("Text2")
Dim Text3 As String
Text3 = myWorksheet.Range("Text3")
Dim ReportTemplateFilePath As String
ReportTemplateFilePath = myWorksheet.Range("ReportTemplateFilePath")
Dim ReportTemplateFileName As String
ReportTemplateFileName = myWorksheet.Range("ReportTemplateFileName")
Dim SaveToLocation As String
SaveToLocation = myWorksheet.Range("SaveToLocation")
Dim SourceTargetSheet As Excel.Worksheet
Set SourceTargetSheet = myWorkbook.Sheets(PasteSheetName)
Dim TargetWorkbook As Excel.Workbook
Set TargetWorkbook = Workbooks.Open(FilePath)
Dim TargetSheet As Excel.Worksheet
Set TargetSheet = TargetWorkbook.Sheets(TargetSheetName)
'Clear old info
Dim UpperLeftHandCornerOfClear As String
UpperLeftHandCornerOfClear = "A" & PasteTargetRow
Dim LowerRightHandCornerOfClear As String
LowerRightHandCornerOfClear = "XFD" & PasteTargetRow2
SourceTargetSheet.Range(UpperLeftHandCornerOfClear, LowerRightHandCornerOfClear).ClearContents
'Copy new info for pasting
Dim StartingColumnAsRange As Range
Set StartingColumnAsRange = TargetSheet.Cells.Find(Identifier, LookIn:=xlValues, LookAt:=xlPart)
If Not StartingColumnAsRange Is Nothing Then
Dim StartingColumn As String
StartingColumn = Split(StartingColumnAsRange.Address, "$")(1)
End If
Dim EndingColumnAsRange As Range
Set EndingColumnAsRange = TargetSheet.Cells.Find(Identifier2, LookIn:=xlValues, LookAt:=xlPart)
If Not EndingColumnAsRange Is Nothing Then
Dim EndingColumn As String
EndingColumn = Split(EndingColumnAsRange.Address, "$")(1)
End If
Dim UpperLeftHandCornerOfCopy As String
UpperLeftHandCornerOfCopy = StartingColumn & TargetRow
Dim LowerRightHandCornerOfCopy As String
LowerRightHandCornerOfCopy = EndingColumn & TargetRow2
TargetSheet.Range(UpperLeftHandCornerOfCopy, LowerRightHandCornerOfCopy).Copy
Dim PastePasteTarget As String
PastePasteTarget = "A" & PasteTargetRow
SourceTargetSheet.Range(PastePasteTarget).PasteSpecial Paste:=xlPasteValues
'Create a Microsoft Word object (instance of Word to control)
Dim WordApplication As Word.Application
Set WordApplication = CreateObject("Word.Application")
'Error handle if Microsoft Word is open
On Error Resume Next
Set WordApplication = GetObject(class:="Word.Application")
Err.Clear
If WordApplication Is Nothing Then
Set WordApplication = CreateObject(class:="Word.Application")
End If
On Error GoTo 0
'Error handle if report template is specifically already open
On Error Resume Next
Application.DisplayAlerts = False
Documents(ReportTemplateFileName).Close SaveChanges:=wdDoNotSaveChanges
On Error GoTo 0
Application.DisplayAlerts = True
Dim WordDocument As Word.Document
Set WordDocument = WordApplication.Documents.Open(ReportTemplateFilePath)
'Content from 'myWorksheet'
With WordDocument
.Bookmarks("Bookmark1").Range.Text = myWorksheet.Range("Text1")
.Bookmarks("Bookmark2").Range.Text = myWorksheet.Range("Text2")
.Bookmarks("Bookmark3").Range.Text = myWorksheet.Range("Text3")
.Bookmarks("Bookmark4").Range.Text = myWorksheet.Range("Text4")
End With
'Content from 'myWorksheet2'
With WordDocument
.Bookmarks("Bookmark5").Range.Text = myWorksheet2.Range("Text5")
.Bookmarks("Bookmark6").Range.Text = myWorksheet2.Range("Text6")
.Bookmarks("Bookmark7").Range.Text = myWorksheet2.Range("Text7")
.Bookmarks("Bookmark8").Range.Text = myWorksheet2.Range("Text8")
.Bookmarks("Bookmark9").Range.Text = myWorksheet2.Range("Text9")
.Bookmarks("Bookmark10").Range.Text = myWorksheet3.Range("Text10")
End With
'Chart (alone on worksheet)
WordApplication.Selection.Goto What:=wdGoToBookmark, Name:="Chart1"
ThisWorkbook.Sheets("Chart 1 Worksheet Name").ChartObjects(1).Copy
WordApplication.Selection.Paste
WordApplication.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
'Two charts grouped together
WordApplication.Selection.Goto What:=wdGoToBookmark, Name:="Chart2"
ThisWorkbook.Sheets("Chart 2 Worksheet Name").ChartObjects(1).Copy
WordApplication.Selection.Paste
WordApplication.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
With WordDocument
.SaveAs FileName:=SaveToLocation & " " & Text3, _
FileFormat:=wdFormatDocumentDefault
.Close
End With
WordApplication.Quit
Set WordApplication = Nothing
Set WordDocument = Nothing
Application.ScreenUpdating = True
'Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
myWorksheet.Activate
MsgBox "Report successfully generated.", vbInformation, "Completed!"
End Sub
Try modifying your Word application creation script - this is all you need:
On Error Resume Next
Set WordApplication = GetObject(class:="Word.Application")
On Error GoTo 0
If WordApplication Is Nothing Then
Set WordApplication = CreateObject(class:="Word.Application")
End If
It may be that Word is waiting for some input from you but you're not seeing it because you didn't make the instance visible, so try also adding:
WordApplication.Visible = True
I am looking in the Folder for specific file in .docx and want to open it. I put the Name of X into Inputbox, go to Sheet Y, look on the next right cell of X and open this as Word (next cell right is an file in word I want to open). It is working, but the Problem is that the target Word Doc may be in multiples subfolders. Is there any quick way to search in These subfolder?
Private Sub CommandButton1_Click()
On Error GoTo ErrorHandling
Application.ScreenUpdating = False
Dim AppWD As Object
Dim SearchX As String
Dim SearchArea As Range
Dim Y As String
Dim sPath As String
sPath = "C:\Users\VS\Desktop\test"
SearchRule = InputBox("X")
Set SearchArea = Sheets("Look").Range("A:A").Find(what:=SearchX, _
LookIn:=xlFormulas, lookat:=xlWhole)
ActiveWindow.Visible = True
Target = SearchArea.Offset(0, 1).Value
Set AppWD = CreateObject("Word.Application")
AppWD.Visible = True
AppWD.documents.Open (sPath & "\" & Target & "." & "docx")
ErrorHandling: Exit Sub
End Sub
My take on searching throught subfolders
Sub searchSub()
Dim fso As FileSystemObject, fFile As File, fFolder As Folder
Dim fSubFolder As Folder, fPath As String, FileToSearch As String
Set fso = New FileSystemObject
FileToSearch = "SomeDocument.docx"
fPath = ThisWorkbook.Path
Set fFolder = fso.GetFolder(fPath)
For Each fFolder In fFolder.SubFolders
Set fSubFolder = fso.GetFolder(fFolder.Path)
For Each fFile In fSubFolder.Files
If fFile.Name = FileToSearch Then
'do something with file
End If
Next fFile
Next fFolder
End Sub
I have written the below code to loop through all the files in a directory and copy certain values from them and paste it back into the master file.
The problem that I am having is that the code never fully runs through all the files and I never get an error.
As shown in the picture the file names are depicted as 1 - #####, then 2 - ####, etc.
Sometimes there are multiple of the first number like in the picture there are two 1 - ###'s but the end numbers are still different.
The problem is that instead of going by the actual numerical order the code is using only the first number and going from 1, 10, 11, 100 and completely skipping the rest.
Any ideas on how to solve this?
Sub ReadDataFromCloseFile()
On Error GoTo ErrHandler
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim FileType As String
Dim FilePath As String
FileType = "*.xlsm*" 'The file type to search for
FilePath = "\\filepath\" 'The folder to search
Dim src As Workbook
Dim OutputCol As Variant
Dim Curr_File As Variant
OutputCol = 9 'The first row of the active sheet to start writing to
Curr_File = Dir(FilePath & FileType)
Do Until Curr_File = ""
' OPEN THE SOURCE EXCEL WORKBOOK IN "READ ONLY MODE".
Set src = Workbooks.Open(FilePath & Curr_File, True, True)
Sheets("Reporting").Range("I7:I750").Copy
Workbooks("Master.xlsm").Activate
Sheets("Sheet2").Select
Sheets("Sheet2").Cells(4, OutputCol).Select
ActiveCell.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
OutputCol = OutputCol + 1
' CLOSE THE SOURCE FILE.
src.Close False ' FALSE - DON'T SAVE THE SOURCE FILE.
Curr_File = Dir
Loop
Set src = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Filepath
I've no idea why it doesn't open the 2 to 9 files. This version puts all the file paths into a collection and then steps through the collection.
It also does away with selecting the sheets before pasting, etc.
Sub ReadDataFromCloseFile()
Dim FileType As String
Dim FilePath As String
Dim colFiles As Collection
Dim src As Workbook
Dim tgt As Workbook
Dim OutputCol As Variant
Dim Curr_File As Variant
Set colFiles = New Collection
FileType = "*.xlsm*" 'The file type to search for
FilePath = "\\filepath\" 'The folder to search
EnumerateFiles FilePath, FileType, colFiles
OutputCol = 9 'The first row of the active sheet to start writing to
'If Master.xlsm is the book containing this code then use '=ThisWorkbook'
Set tgt = Workbooks("Master.xlsm")
For Each Curr_File In colFiles
Set src = Workbooks.Open(Curr_File, True, True)
src.Worksheets("Reporting").Range("I7:I750").Copy
tgt.Worksheets("Sheet2").Cells(4, OutputCol).PasteSpecial xlPasteValuesAndNumberFormats
OutputCol = OutputCol + 1
src.Close False
Next Curr_File
End Sub
Sub EnumerateFiles(ByVal sDirectory As String, _
ByVal sFileSpec As String, _
ByRef cCollection As Collection)
Dim sTemp As String
sTemp = Dir$(sDirectory & sFileSpec)
Do While Len(sTemp) > 0
cCollection.Add sDirectory & sTemp
sTemp = Dir$
Loop
End Sub
It might be easier for you to loop through the files using the below loop.
Sub LoopFiles()
Dim FSO As New FileSystemObject
Dim Fldr As Folder
Dim Fl As File
'Loop through files in folder
For Each Fl In FSO.GetFolder(filePath).Files
'Check for file type
If Fl.Type = "Excel Macro-Enabled Workbook" Then
'Open file & do procedure
End If
Next
Set FSO = Nothing
End Sub
Try declaring your variable OutputCol as an integer and not a variant. If you know your data is always going to be a number, it's never a good idea to use a variant. It takes more resources to execute the code and you don't know all of the internal logic that is going on behind the scenes. It also gives you more control of the code's execution and probably won't give you headaches like this one. Only use a variant if you don't know what data you are going to output.
Hope this helps!
I try to call a VBA subroutine from VBS with passing a string variable from VBS to VBA, but can't find the appropiate syntax:
'VBS:
'------------------------
Option Explicit
Set ArgObj = WScript.Arguments
Dim strPath
mystr = ArgObj(0) '?
'Creating shell object
Set WshShell = CreateObject("WScript.Shell")
'Creating File System Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Getting the Folder Object
Set ObjFolder = objFSO.GetFolder(WshShell.CurrentDirectory)
'Getting the list of Files
Set ObjFiles = ObjFolder.Files
'Creat a Word application object
Set wdApp = CreateObject("Word.Application")
wdApp.DisplayAlerts = True
wdApp.Visible = True
'Running macro on each wdS-File
Counter = 0
For Each objFile in objFiles
If UCase(objFSO.GetExtensionName(objFile.name)) = "DOC" Then
set wdDoc = wdApp.Documents.Open(ObjFolder & "\" & ObjFile.Name, 0, False)
wdApp.Run "'C:\Dokumente und Einstellungen\kcichini\Anwendungsdaten\Microsoft\Word\STARTUP\MyVBA.dot'!Test_VBA_with_VBS_Args" (mystr) 'how to pass Argument???
Counter = Counter + 1
End if
Next
MsgBox "Macro was applied to " & Counter & " wd-Files from current directory!"
wdApp.Quit
Set wdDoc = Nothing
Set wdApp = Nothing
'------------------------
'VBA:
'------------------------
Sub Test_VBA_with_VBS_Args()
Dim wdDoc As Word.Document
Set wdDoc = ActiveDocument
Dim filename As String
Dim mystr As String
'mystr = how to recognize VBS-Argument ???
filename = ActiveDocument.name
MsgBox "..The file: " & filename & " was opened and the VBS-Argument: " & mystr & "recognized!"
wdDoc.Close
End Sub
'------------------------
You need to specify parameters in your VBA Sub and use them as you would do if using it from VBA normally.
For example, I tried the following VBScript
dim wd: set wd = GetObject(,"Word.Application")
wd.Visible = true
wd.run "test", "an argument"
and the VBA
Sub Test(t As String)
MsgBox t
End Sub
which worked successfully, generating a message box.
Addendum to #user69820 answer, if arguments are VBScript variables, they need to be cast as appropriate type before calling the subroutine:
This does not work:
dim argumentVariable
argumentVariable = "an argument"
wd.run "test", argumentVariable
This does:
dim argumentVariable
argumentVariable = "an argument"
wd.run "test", CStr(argumentVariable)
Tested on Excel 2010, Win7SP1 x64
I have below Excel procedure I gather up and I am using it for couple of different calculations under different workbooks. So I was thinking instead changing the procedure for main and outcome files each time, I should be able to pick the file I want to carry out calculations in and the file path for outcomes files.
But I could not find anything for saving directory, I appreciate if you could help
Sub AsBuiltForm()
Dim SaveName As String
Dim mainBook As Workbook
a = InputBox("ENTER FIRST NUMBER ")
b = InputBox("ENTER LAST NUMBER ")
Workbooks.Open Filename:="C:\" 'main file can be browsed?
Set mainBook = Excel.Workbooks("CP.xlsx")
For i = a - 1 To b - 1
mainBook.Sheets(1).Range("bi1") = i + 1
SaveName = Sheets(1).Range("bi1").value & ".xlsx"
mainBook.SaveCopyAs "C:\" & SaveName 'save directory?
Workbooks.Open Filename:="C:\" & SaveName 'save directory?
With Excel.ActiveWorkbook
.Sheets("1 of 2").Range("A1:CT103").value = Sheets("1 of 2").Range("A1:CT103").value
.Sheets("2 of 2").Range("A1:CT103").value = Sheets("2 of 2").Range("A1:CT103").value
Excel.Application.DisplayAlerts = False
.Sheets("Sheet1").Delete
.Sheets("il oufall").Delete
.Sheets("1 of 2").Select
Columns("Bh:BZ").Select
Selection.Delete Shift:=xlToLeft
.Sheets("2 of 2").Select
Columns("Bn:BZ").Select
Selection.Delete Shift:=xlToLeft
.Close True
End With
Next
mainBook.Close False
Set mainBook = Nothing
End Sub
You can use Application.GetOpenFileName to pick files that you want to open at Run-Time.
You can use the function below to browse for a folder where you wish to save a file.
Sub FindFolder()
Dim myFolder as String
myFolder = BrowseFolder("Pick a Folder Where to Save")
End Sub
Function BrowseFolder(Optional Caption As String, Optional InitialFolder As String) As String
' based on Browse For Folder from:
' http://www.cpearson.com/excel/BrowseFolder.aspx
' this functions requires that the following Reference is active:
'Microsoft Shell Controls and Automation
Const BIF_RETURNONLYFSDIRS As Long = &H1
Dim wsh As Object
Dim SH As Shell32.Shell
Dim F As Shell32.Folder
Set wsh = CreateObject("Wscript.Shell")
Set SH = New Shell32.Shell
Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, InitialFolder)
If Not F Is Nothing Then
If F = "Desktop" Then
BrowseFolder = wsh.Specialfolders(F)
Else
BrowseFolder = F.Items.Item.path
End If
End If
End Function
The following is not really an answer to your question, but a few tips to improve your code, and too long to add as a comment.
Workbooks.Open returns a Workbook object you can save the reference, so you don't have to rely on ActiveWorkbook:
Dim oWorkbook As Workbook
Set oWorkbook = Workbooks.Open(Filename:="C:\" & SaveName)
'***** Do something with oWorkbook
Debug.Print oWorkbook.FullName
Set oWorkbook = Nothing
A few other hints:
Use Option Explicit at the top of every module to force explicit declaration of all variables in order to find typos and other errors earlier.
Avoid selecting cells
Yes, browsing file works now; all the ins and outs aside, the problem i face with naming the file due to the variable "bi1" and saving as many loop as i asked for. I check several times before i bother you but i do not think i have the sufficient info to address "fn" as file in the use of Application.GetOpenFileName .
Option Explicit
Sub AsBuiltForm()
Dim fn
Dim myFolder As String
Dim SaveName As String, a As Integer, b As Integer, i As Integer
myFolder = BrowseFolder("Pick a Folder Where to Save")
MsgBox "Choose Calculation File "
fn = Application.GetOpenFilename
Workbooks.Open fn
a = InputBox("ENTER FIRST NUMBER ")
b = InputBox("ENTER LAST NUMBER ")
For i = a - 1 To b - 1 Step 1
Application.DisplayAlerts = False
Workbooks.Open Filename:=fn
Range("bi1") = i + 1
SaveName = ActiveWorkbook.Sheets(1).Range("bi1").value
Sheets(1).Range("A1:CT103").value = Sheets(1).Range("A1:CT103").value
Sheets(2).Range("A1:CT103").value = Sheets(2).Range("A1:CT103").value
Application.ActiveWorkbook.SaveAs myFolder & SaveName
ActiveWorkbook.Close True
Next
End Sub
Function BrowseFolder(Optional Caption As String, Optional InitialFolder As String) As String
' based on Browse For Folder from:
' http://www.cpearson.com/excel/BrowseFolder.aspx
' this functions requires that the following Reference is active:
'Microsoft Shell Controls and Automation
Const BIF_RETURNONLYFSDIRS As Long = &H1
Dim wsh As Object
Dim SH As Shell32.Shell
Dim F As Shell32.Folder
Set wsh = CreateObject("Wscript.Shell")
Set SH = New Shell32.Shell
Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, InitialFolder)
If Not F Is Nothing Then
If F = "Desktop" Then
BrowseFolder = wsh.Specialfolders(F)
Else
BrowseFolder = F.Items.Item.Path
End If
End If
End Function