I'm trying to copy information from an excel sheet to a new word document. Currently everything copies correctly on the first loop, but pastes into the previously pasted table in the next loop. I've tried every variation of ways to exit the table I can find through searching and none seem to fix the issue. Hoping someone can help.
Sub createWord()
Dim objWord
Dim objDoc
Dim heading As New DataObject
Dim fileName As String
Dim tableRange As Word.Range
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add()
fileName = ActiveWorkbook.Name
fileName = Left$(fileName, InStrRev(fileName, ".") - 1) & " Data.doc"
'objDoc.SaveAs fileName:=ThisWorkbook.Path & "\" & fileName
objWord.Visible = True
For i = 4 To Application.Sheets.Count
Dim k As Integer
k = ((i - 4) * 4) + 1
heading.SetText ThisWorkbook.Worksheets(i).Cells(1, 4).Value
heading.PutInClipboard
objDoc.Paragraphs.Add
objDoc.Paragraphs(k).Range.Paste
k = k + 1
Call copyGraphAuto(i)
objDoc.Paragraphs.Add
objDoc.Paragraphs(k).Range.Paste
k = k + 1
heading.SetText ThisWorkbook.Worksheets(i).Cells(24, 5).Value
heading.PutInClipboard
objDoc.Paragraphs.Add
objDoc.Paragraphs(k).Range.Paste
k = k + 1
Call copyTableAuto(i)
objDoc.Paragraphs.Add
objDoc.Paragraphs(k).Range.Paste
Set tableRange = objDoc.Tables(k - 3).Range
tableRange.Collapse Direction:=wdCollapseEnd
'Exit For
Next i
End Sub
Sub copyTableAuto(Optional ByVal sheetNumber As Integer)
Dim ppmCount As Integer
If sheetNumber = 0 Then sheetNumber = ThisWorkbook.ActiveSheet.Index
ppmCount = Worksheets(sheetNumber).Range("M4:M9").Cells.SpecialCells(xlCellTypeConstants).Count
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Worksheets(sheetNumber).Range("E29:E" & CStr(ppmCount + 28)).Merge
Worksheets(sheetNumber).Range("E25:I" & CStr(ppmCount + 28)).Copy
End Sub
Thanks
The issue is caused by your attempt to maintain an index of the paragraphs in the document.
As you are adding data to the document consecutively it would be better, and simpler, to use Word's own index and work with:
objDoc.Paragraphs.Last.Range
Related
I'm trying to create a set of plates (group of 5 rows with some data took from the mainsheet) and create a Word file that put 2 plate per page. Before every plate i wanna insert a logo (i'm trying to add the logo in the for cycle but i'm lost right now), with a custom style (the same as the result page)
I have part of the code i came up with until now, and i show you the result i'm trying to obtain:
(First pic the final result, the second the result i'm obtaining right now)
Option Explicit
Sub PrintLabels_Word()
Dim wb As Workbook, ws As Worksheet, wsPDF As Worksheet, xWs As Worksheet, WdObj As Object
Dim iLastRow As Long, ar(1 To 7, 1 To 1), rng As Range
Dim i As Long, r As Long, c As Integer, k As Integer
Dim LastRow As Long
Dim area As Range
Dim saveLocation As String
Dim strFileName As String, myRow As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("Summary")
Set wsPDF = wb.Sheets("Foglio1")
Set xWs = Application.ActiveSheet
wsPDF.Cells.Clear
xWs.ResetAllPageBreaks
' fixed
ar(1, 1) = ws.Cells(1, 10)
ar(2, 1) = "CLIENT: " & ws.Cells(1, 7)
ar(3, 1) = "ORDER" & " " & ws.Cells(2, 7)
ar(5, 1) = "JOB" & " " & ws.Cells(1, 2) & " " & ws.Cells(1, 3)
ar(6, 1) = "CASE NUMBER: 1/1"
iLastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
r = 1 ' start row
c = 1 ' column A
For i = 6 To iLastRow
ar(4, 1) = "INSIDE CASE (TAG): " & ws.Cells(i, "H")
' fill plate
Set rng = wsPDF.Cells(r, c).Resize(7, 1)
rng.Value2 = ar
' merge cells
For k = 1 To 7
With rng.Cells(k, 1).Resize(1, 4)
.Merge
.HorizontalAlignment = xlCenter
.Font.Bold = True
End With
Next
r = r + 8
Next
MsgBox "Done"
With ActiveSheet.PageSetup
.Orientation = xlPortrait
.Zoom = 200
.FitToPagesTall = False
.FitToPagesWide = False
End With
Dim tblRange As Excel.Range
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim WordTable As Word.Table
iLastRow = wsPDF.Cells(Rows.Count, 1).End(xlUp).Row
Set tblRange = ThisWorkbook.Worksheets("Foglio1").Range("A1:D" & iLastRow)
On Error Resume Next
Set WordApp = GetObject(class:="Word.Application")
If WordApp Is Nothing Then Set WordApp = CreateObject(class:="Word.Application")
'WordApp.Visible = True
'WordApp.Activate
Set WordDoc = WordApp.Documents.Add
tblRange.Copy
WordDoc.Paragraphs(1).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
With WordApp
.ChangeFileOpenDirectory ThisWorkbook.Path
.ActiveDocument.SaveAs Filename:="Targhetta Adesiva" & " " & ws.Range("B3").Value & "_" &
ws.Range("G1").Value & ".doc"
.ActiveDocument.Close
End With
End Sub
You are trying to re-invent the wheel. Word already has all the functionality you need. It is called a mail merge (or Mailing) and it can use data from Excel.
To get multiple plates on one page, start with a Label merge setup and customise the layout table to suit your needs.
To do a mail merge with images, store all the images into one folder, put a unique image ID and each image path into the Excel source as two separate data columns. Then plug that information into the image merge field.
For more details see https://community.spiceworks.com/how_to/2675-using-mailmerge-to-insert-images
All that can be done without writing a single line of VBA.
I have about 100 Word documents and from each I want to copy data and paste it all in one Excel workbook.
I came up with this code which opens one Word document, copies data, pastes it to Excel and closes the Word document:
Sub WordDataToExcel()
Dim myObj
Dim myWB
Dim mySh
Dim txt As String, Lgth As Long, Strt As Long
Dim i As Long
Dim oRng As Range
Dim Tgt As String
Dim TgtFile As String
Dim arr()
Dim ArrSize As Long
Dim ArrIncrement As Long
ArrIncrement = 1000
ArrSize = ArrIncrement
ReDim arr(ArrSize)
Dim wrdDoc As Object
Documents.Open ("D:\ekr5_i.doc")
TgtFile = "result.xlsx"
Tgt = "D:\" & TgtFile
'finds the text string of Lgth lenght
txt = "thetext"
Lgth = 85
Strt = Len(txt)
'Return data to array
With Selection
.HomeKey unit:=wdStory
With .Find
.ClearFormatting
.Forward = True
.Text = txt
.Execute
While .Found
i = i + 1
Set oRng = ActiveDocument.Range _
(Start:=Selection.Range.Start + Strt, _
End:=Selection.Range.End + Lgth)
arr(i) = oRng.Text
oRng.Start = oRng.End
.Execute
If i = ArrSize - 20 Then
ArrSize = ArrSize + ArrIncrement
ReDim Preserve arr(ArrSize)
End If
Wend
End With
End With
ReDim Preserve arr(i)
'Set target and write data
Set myObj = CreateObject("Excel.Application")
Set myWB = myObj.Workbooks.Open(Tgt)
Set mySh = myWB.Sheets(1)
With mySh
.Range(.Cells(1, 1), .Cells(i, 1)) = myObj.Transpose(arr)
End With
'Tidy up
myWB.Close True
myObj.Quit
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
Set mySh = Nothing
Set myWB = Nothing
Set myObj = Nothing
End Sub
I need to loop through all the documents in the folder.
I have implemented the same with Excel workbooks, but I don't know how for Word documents.
Here is the code for Excel workbooks:
Sub combine_into_one()
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim strPath$, Pivot$, sUserName$, sFolderName$, sSourceName$, x&
Dim oFldialog As FileDialog
Dim oFolder
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set oFldialog = Application.FileDialog(msoFileDialogFolderPicker)
With oFldialog
If .Show = -1 Then
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
sFolderName = .SelectedItems(1)
End If
End With
Set oFolder = FSO.GetFolder(sFolderName)
Workbooks.Add: Pivot = ActiveWorkbook.Name 'Destination workbook
For Each oFile In oFolder.Files
Workbooks(Pivot).Activate
x = Workbooks(Pivot).Sheets(1).Cells.SpecialCells(xlCellTypeLastCell).Row + 1
Workbooks.Open Filename:=oFile: sSourceName = ActiveWorkbook.Name
Workbooks(sSourceName).Activate
Workbooks(sSourceName).Sheets(1).[A80:Q94].copy
Workbooks(Pivot).Activate
Workbooks(Pivot).Sheets(1).Cells(x + 1, 1).PasteSpecial xlPasteAll
Workbooks(sSourceName).Close False
Next
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
There are so, so, so many things you can do between Excel & Word. I'm not sure I totally understand your question. The script below may help you; it has definitely served me well over time. If you need something different, please describe your issue more, to better clarify the issue you are facing.
Sub OpenAndReadWordDoc()
Rows("2:1000000").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("A1").Select
' assumes that the previous procedure has been executed
Dim oWordApp As Word.Application
Dim oWordDoc As Word.Document
Dim blnStart As Boolean
Dim r As Long
Dim sFolder As String
Dim strFilePattern As String
Dim strFileName As String
Dim sFileName As String
Dim ws As Worksheet
Dim c As Long
Dim n As Long
'~~> Establish an Word application object
On Error Resume Next
Set oWordApp = GetObject(, "Word.Application")
If Err Then
Set oWordApp = CreateObject("Word.Application")
' We started Word for this macro
blnStart = True
End If
On Error GoTo ErrHandler
Set ws = ActiveSheet
r = 1 ' startrow for the copied text from the Word document
' Last column
n = ws.Range("A1").End(xlToRight).Column
sFolder = "C:\Users\Excel\Desktop\Coding\Microsoft Excel\PWC\Resumes\"
'~~> This is the extension you want to go in for
strFilePattern = "*.doc*"
'~~> Loop through the folder to get the word files
strFileName = Dir(sFolder & strFilePattern)
Do Until strFileName = ""
sFileName = sFolder & strFileName
'~~> Open the word doc
Set oWordDoc = oWordApp.Documents.Open(sFileName)
' Increase row number
r = r + 1
' Enter file name in column A
ws.Cells(r, 1).Value = sFileName
ActiveCell.Offset(1, 0).Select
ActiveSheet.Hyperlinks.Add Anchor:=Sheets("Sheet1").Range("A" & r), Address:=sFileName, _
SubAddress:="A" & r, TextToDisplay:=sFileName
' Loop through the columns
For c = 2 To n
If oWordDoc.Content.Find.Execute(FindText:=Trim(ws.Cells(1, c).Value), _
MatchWholeWord:=True, MatchCase:=False) Then
' If text found, enter Yes in column number c
ws.Cells(r, c).Value = "Yes"
End If
Next c
oWordDoc.Close SaveChanges:=False
'~~> Find next file
strFileName = Dir
Loop
ExitHandler:
On Error Resume Next
' close the Word application
Set oWordDoc = Nothing
If blnStart Then
' We started Word, so we close it
oWordApp.Quit
End If
Set oWordApp = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
Function GetDirectory(path)
GetDirectory = Left(path, InStrRev(path, "\"))
End Function
In this scenario, whatever you put in the headers of B1:K1 (or more to the right) is searched for, each word document in a folder is opened, scanned, and if the string in B1:K1 is found, an 'x' is placed in the same x-y coordinate.
Again, if this doesn't help, please describe your issue better, and I'll post back with alternative solutions. Thanks!!
I am trying to create word documents based on an excel table as follows:
At the end this creates 3 documents and each one has only the lines with Yes corresponding to it. My problem is that it doesn't keep the formatting of the lines. Can somebody help me with this? Here is the code:
Sub NewWordDocument()
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim i As Integer
Dim j As Integer
Dim LineCount As Integer
Dim DocumentCount As Integer
LineCount = Application.CountA(Range("A:A")) ' To see how many lines should be inputed
DocumentCount = Application.CountA(Range("B2:AZ2")) 'To see how many documents should be created
For j = 1 To DocumentCount
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Add ' or 'Set wrdDoc =wrdApp.Documents.Open("C:\Foldername\Filename.doc") 'sample word operations
wrdApp.Selection.TypeText Text:="Heading One"
With wrdDoc
For i = 1 To LineCount
If Cells(i + 2, j + 1).Value = "Yes" Then
.Range.InsertAfter Cells(i + 2, 1) 'Different way to paste the text. It doesn't keep the formatting
.Range.InsertParagraphAfter
End If
Next i
If Dir("D:\" & Cells(2, j + 1).Value & ".docx") <> "" Then
Kill "D:\" & Cells(2, j + 1).Value & ".docx"
End If
.SaveAs ("D:\" & Cells(2, j + 1).Value & ".docx")
.Close ' close the document
End With
wrdApp.Quit ' close the Word application
Set wrdDoc = Nothing
Set wrdApp = Nothing
Next j
End Sub
If I do it manually, copying the cell and pasting it in word works perfectly - keeps the format and removes the table but when I use 'Selection.PasteExcelTable False, False, False' instead of 'InsertAfter' , I simply overwrite the same text instead of adding to the end of the page.
Also, how can I format the "Heading one" to be bold and center?
I figured it out - it is probably not the best way to do it but it more or less works for me.
Sub NewWordDocument()
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim i As Integer
Dim j As Integer
Dim LineCount As Integer
Dim DocumentCount As Integer
LineCount = Application.CountA(Range("A:A")) ' To see how many lines should be inputed
DocumentCount = Application.CountA(Range("B2:AZ2")) 'To see how many documents should be created
For j = 1 To DocumentCount
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Add ' or 'Set wrdDoc = wrdApp.Documents.Open("C:\Foldername\Filename.doc") 'sample word operations
wrdApp.Selection.Font.Name = "Calibri"
wrdApp.Selection.Font.Size = 18
wrdApp.Selection.Font.Allcaps = True
wrdApp.Selection.Font.Bold = True
wrdApp.Selection.TypeText Text:="Title"
With wrdDoc
.Sections(1).Footers(wdHeaderFooterPrimary).PageNumbers.Add _
PageNumberAlignment:=wdAlignPageNumberRight, _
FirstPage:=True
.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = "Header text" 'Add text in the header
.Content.InsertParagraphAfter
For i = 1 To LineCount
If Cells(i + 2, j + 1).Value = "Yes" Then
Range("A" & i + 2).Copy
wrdApp.Selection.GoTo What:=wdGoToBookmark, Name:="\Page"
wrdApp.Selection.MoveRight Unit:=wdCharacter, Count:=1
wrdApp.Selection.PasteSpecial
.Content.InsertParagraphAfter
End If
Next i
wrdApp.Selection.Font.Name = "Calibri"
wrdApp.Selection.Font.Size = 11
wrdApp.Selection.Font.Allcaps = False
wrdApp.Selection.Font.Bold = False
wrdApp.Selection.TypeText Text:="Ending Text"
If Dir("D:\" & Cells(2, j + 1).Value & ".docx") <> "" Then
Kill "D:\" & Cells(2, j + 1).Value & ".docx"
End If
.SaveAs ("D:\" & Cells(2, j + 1).Value & ".docx")
.Close ' close the document
End With
wrdApp.Quit ' close the Word application
Set wrdDoc = Nothing
Set wrdApp = Nothing
Next j
End Sub
I have a macro that reads the unread messages in my inbox and extracts the data from the message with a delimiter of ":" . In the loop I want to be able to load the new excel spreadsheet with the values from the message.
I am able to select the first cell and save the data but it is getting over written. each time in the loop I want the data to go to the next cell in the column that is empty instead of overwriting the same cell.
Here is my code so far...
Public Sub Application_NewMail()
Dim newbk As Workbook
Set newbk = Workbooks.Add
newbk.SaveAs "C:\Users\RickG\Desktop\test2.xlsx" 'other parameters can be set here if required
' perform operations on newbk
newbk.Close savechanges:=True
Dim ns As Outlook.NameSpace
Dim InBoxFolder As MAPIFolder
Dim InBoxItem As Object 'MailItem
Dim Contents As String, Delimiter As String
Dim Prop, Result
Dim i As Long, j As Long, k As Long
'Setup an array with all properties that can be found in the mail
Prop = Array("Name", "Email", "Phone", "Customer Type", _
"Message")
'The delimiter after the property
Delimiter = ":"
Set ns = Session.Application.GetNamespace("MAPI")
'Access the inbox folder
Set InBoxFolder = ns.GetDefaultFolder(olFolderInbox)
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim ws As Worksheet
Set xlApp = New Excel.Application
With xlApp
.Visible = False
Set xlWB = .Workbooks.Open("C:\Users\RickG\Desktop\test2.xlsx", , False)
Set ws = .Worksheets("Sheet1")
End With
Dim LR As Long
For Each InBoxItem In InBoxFolder.Items
'Only process mails
If Not TypeOf InBoxItem Is MailItem Then GoTo SkipItem
'Skip wrong subjects
If InStr(1, InBoxItem.Subject, "FW: New Lead - Consumer - Help with Medical Bills", vbTextCompare) = 0 Then GoTo SkipItem
'Already processed?
If Not InBoxItem.UnRead Then GoTo SkipItem
'Mark as read
InBoxItem.UnRead = False
'Get the body
Contents = InBoxItem.Body
'Create space for the result
ReDim Result(LBound(Prop) To UBound(Prop)) As String
'Search each property
i = 1
For k = LBound(Prop) To UBound(Prop)
'Find the property (after the last position)
i = InStr(i, Contents, Prop(k), vbTextCompare)
If i = 0 Then GoTo NextProp
'Find the delimiter after the property
i = InStr(i, Contents, Delimiter)
If i = 0 Then GoTo NextProp
'Find the end of this line
j = InStr(i, Contents, vbCr)
If j = 0 Then GoTo NextProp
'Store the related part
Result(k) = Trim$(Mid$(Contents, i + Len(Delimiter), j - i - Len(Delimiter)))
'for every row, find the first blank cell and select it
'MsgBox Result(k)
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("A" & LR).Value = Result(k)
'Update the position
i = j
NextProp:
Next
xlApp.DisplayAlerts = False
xlWB.SaveAs ("C:\Users\RickG\Desktop\test2.xlsx")
xlWB.Close
xlApp.Quit
If MsgBox(Join(Result, vbCrLf), vbOKCancel, "Auto Check In") = vbCancel Then Exit Sub
SkipItem:
Next
End Sub
You're not tracking your loop correctly. If you change
Range("A" & LR).Value = Result(k)
to
Range("A" & LR + 1).Value = Result(k)
in your
For k = LBound(Prop) To UBound(Prop)
loop, that should correct your issue.
EDIT: Sorry, findwindow. I didn't see the comment thread below the question. I just saw that the question had no answer yet.
I wrote this Access/VBA program. It works but only when I am not running other applications or few users are in the database. I need some ideas on streamlining the code. So it is not so system intensive. The program basically allows a user to pick a folder and then combines all worksheets in that folder in one excel document. My current idea is just to tell users to close all excel files when trying to run the program. Please Help:
Sub Excel_open()
Dim myXL As Excel.Application
Dim myXLS As Excel.Workbook
Const errExcelNotRunning = 429
On Error GoTo HandleIt
Set myXL = GetObject(, "Excel.application")
myXL.Visible = True
Set myXLS = myXL.Workbooks.Add
Call CombineWorkbooks(myXL)
HandleIt:
If Err.Number = errExcelNotRunning Then
Set myXL = CreateObject("Excel.Application")
Err.Clear
Resume Next
End If
End Sub
Sub CombineWorkbooks(myXL)
'Macro that combines the files into one folder
myXL.AskToUpdateLinks = False
myXL.DisplayAlerts = False
Dim CurFile As String, dirloc As String, strNamesheet As String
Dim DestWB As Workbook
Dim ws As Object ' allows for diffrent sheet types
'Add select the director function
dirloc = GetFolderName & "\" 'location of files not working want to select the file only
CurFile = Dir(dirloc & "*.xls*")
myXL.ScreenUpdating = False
myXL.EnableEvents = False
Set DestWB = Workbooks.Add(xlWorksheet)
Do While CurFile <> vbNullString
Dim OrigWB As Workbook
Set OrigWB = Workbooks.Open(FileName:=dirloc & CurFile, ReadOnly:=True)
'need to change a name active name is not doing it
CurFile = Left(CurFile, 4) ' This is no longer 29
'CurFile = Left(Left(CurFile, Len(CurFile) - 5), 29)
For Each ws In OrigWB.Sheets
ws.Copy After:=DestWB.Sheets(DestWB.Sheets.Count)
' Use the name to give the sheet a name
strNamesheet = Left((ws.Name), 25) & ";"
If OrigWB.Sheets.Count > 1 Then
DestWB.Sheets(DestWB.Sheets.Count).Name = strNamesheet & CurFile ' & ws.Index
Else
DestWB.Sheets(DestWB.Sheets.Count).Name = CurFile
End If
Next
OrigWB.Close SaveChanges:=False
CurFile = Dir
Loop
myXL.DisplayAlerts = False
DestWB.Sheets(1).Delete
myXL.DisplayAlerts = True
myXL.ScreenUpdating = True
myXL.EnableEvents = True
Set DestWB = Nothing
Call Delete_empty_Sheets(myXL)
Call Sort_Active_Book
MsgBox "Done"
'Call Xcombine_the_Matching
End Sub
Sub Delete_empty_Sheets(myXL)
'goes through all sheets and deletes
Reset_the_search:
For Each wsElement In Worksheets
If wsElement.Range("A2") = "" And wsElement.Range("B2") = "" Then
myXL.DisplayAlerts = False
wsElement.Delete
GoTo Reset_the_search
myXL.DisplayAlerts = True
End If
Next wsElement
End Sub
Sub Xcombine_the_Matching()
'I think I can make the order work
'change and transpose the array
Dim varStart As Variant
Dim wsCompare As Worksheet
Dim strMatch As String
'Dim varCompare As Variant
Dim strVareince As String
Dim strCurrentName As String
'you need to build a loop to solve this problem
For Each wsCompare In Worksheets
strVareince = Add_Array(Application.Transpose(wsCompare.Range("A1:Z1")))
For Each wsNompare In Worksheets
If wsNompare.Name <> strCurrentName Then
If strVareince = Add_Array(Application.Transpose(wsNompare.Range("A1:Z1"))) Then
MsgBox ("Matched with worksheet " & wsNompare.Name)
End If
End If
Next
Next
End Sub
Function array_to_string(x) As String
For Z = 1 To 26
array_to_string = array_to_string & x(Z, 1) & ";"
Next Z
End Function
Function GetFolderName(Optional OpenAt As String) As String
'Allows you to select the folder director that you want to combine
Dim lCount As Long
GetFolderName = vbNullString
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = OpenAt
.Show
For lCount = 1 To .SelectedItems.Count
GetFolderName = .SelectedItems(lCount)
Next lCount
End With
End Function
Function Add_Array(x) As String
'turns an excel document
For d = 1 To UBound(x)
Add_Array = Add_Array & x(d, 1)
Next d
End Function
Sub Read_data()
'this the
End Sub
Sub Sort_Active_Book()
Dim i As Integer
Dim j As Integer
Dim iAnswer As VbMsgBoxResult
'
' Prompt the user as which direction they wish to
' sort the worksheets.
'
iAnswer = MsgBox("Sort Sheets in Ascending Order?" & Chr(10) _
& "Clicking No will sort in Descending Order", _
vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets")
For i = 1 To Sheets.Count
For j = 1 To Sheets.Count - 1
'
' If the answer is Yes, then sort in ascending order.
'
If iAnswer = vbYes Then
If UCase$(Sheets(j).Name) > UCase$(Sheets(j + 1).Name) Then
Sheets(j).Move After:=Sheets(j + 1)
End If
'
' If the answer is No, then sort in descending order.
'
ElseIf iAnswer = vbNo Then
If UCase$(Sheets(j).Name) < UCase$(Sheets(j + 1).Name) Then
Sheets(j).Move After:=Sheets(j + 1)
End If
End If
Next j
Next i
End Sub
You are passing your Excel Application object into your subroutines, but not using it fully, neither are you explicitly referencing the libraries:
Sub CombineWorkbooks(myXL)
Dim DestWB As Excel.Workbook ' <<<
Set DestWB = myXL.Workbooks.Add(xlWorksheet) ' <<<
End Sub
Run through your code and fix all of these first, then test & supply more feedback on what the precise symptoms of the problems are.