Mail merge into a Word document generates Error Code 4248 - excel

My goal is to use two dropdown menus (DM) within a workbook to open a filled-out document.
The DM 1 is to select which row of data will be merged.
The DM 2 is to select which template is being used.
I have separate code that highlights the selected row and opens the document.
Set doc = appWD.ActiveDocument gives me
error 4248 This command is not available because no document is open.
The template is open when I receive this error.
For Context:
Open_LPA_Template, run by itself, does open the Word document selected from the DM 2.
Select_Parcel, run by itself, does highlight the row of data selected from the DM 1.
Sub Run_Mail_Merge_LPA()
Dim doc As Word.Document
Dim appWD As Object
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim tbl As ListObject
Dim row As ListRow
Dim searchValue As String
Dim searchRange As Range
Dim foundCell As Range
' Get references to the workbook and worksheets
Set wb = ThisWorkbook
Set ws = wb.Worksheets(1)
Set ws2 = wb.Worksheets(2)
' Create an instance of the Word application
Set appWD = CreateObject("Word.Application")
' Open the Word document that has been selected in DM 2
Open_LPA_Template
' Select_Parcel's CODE: Select the Row of Data from DM 1 for the Mail Merge
ws2.Select
' Select cell D3 in worksheet 2
ws2.Range("D3").Select
' Store the value in D3 of worksheet 2 in a variable
searchValue = ws2.Range("D3").Value
' Set the search range to the entire column A of worksheet 1
ws.Select
Set searchRange = ws.Range("A:A")
' Use the Find method to search for the search value in the search range
Set foundCell = searchRange.Find(searchValue)
If Not foundCell Is Nothing Then
' If a match is found, select the cell
foundCell.Select
ActiveCell.EntireRow.Select
Else
' If no match is found, print a message
Debug.Print "Value not found in column A"
End If
' MAIL MERGE CODE: Set the active document to the Word document that was opened
Set doc = appWD.ActiveDocument
' Perform the mail merge
doc.MailMerge.MainDocumentType = wdFormLetters
doc.MailMerge.OpenDataSource _
Name:=row.Range, _
ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
WritePasswordDocument:="", WritePasswordTemplate:=""
doc.MailMerge.Execute
End Sub
Sub Open_LPA_Template()
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim MainPath As String
Dim MainPath2 As String
Dim MainPath3 As String
Dim MainPath4 As String
Dim MainPath5 As String
Dim MainPath6 As String
Dim Parcel As String
Dim fileName As String
Dim FullPath As String
Dim mWord As Object
Set wb = ThisWorkbook
Set ws = wb.Worksheets(1)
Set ws2 = wb.Worksheets(2)
Set appWD = CreateObject("Word.Application")
appWD.Visible = True
MainPath = "C:\Users\ME\Dropbox (ORC)\Desktop\Templates\LPA\"
MainPath2 = "C:\Users\USER1\Dropbox (ORC)\Desktop\Templates\LPA\"
MainPath3 = "C:\Users\USER2\Dropbox (ORC)\Desktop\Templates\LPA\"
MainPath4 = "C:\Users\USER3\Dropbox (ORC)\Desktop\Templates\LPA\"
MainPath5 = "C:\Users\USER4\Dropbox (ORC)\Desktop\Templates\LPA\"
MainPath6 = "C:\Users\USER5\Dropbox (ORC)\Desktop\Templates\LPA\"
fileName = ws2.Range("E3")
' Check if the file exists at the first path
If Dir(MainPath & fileName & ".docx") <> "" Then
FullPath = MainPath & fileName & ".docx"
ElseIf Dir(MainPath2 & fileName & ".docx") <> "" Then
' If the file does not exist at the first path, check the second path
FullPath = MainPath2 & fileName & ".docx"
ElseIf Dir(MainPath3 & fileName & ".docx") <> "" Then
' If the file does not exist at either of the first two paths, check the third path
FullPath = MainPath3 & fileName & ".docx"
ElseIf Dir(MainPath4 & fileName & ".docx") <> "" Then
' If the file does not exist at any of the first three paths, check the fourth path
FullPath = MainPath4 & fileName & ".docx"
ElseIf Dir(MainPath5 & fileName & ".docx") <> "" Then
' If the file does not exist at any of the first four paths, check the fifth path
FullPath = MainPath5 & fileName & ".docx"
Else
' If the file does not exist at any of the first five paths, use the sixth path
FullPath = MainPath6 & fileName & ".docx"
End If
appWD.Documents.Open (FullPath)
There are six paths because it could be accessed/used by six people who get to the shared Word documents through their own computers.

Since you are creating a new instance of Word via
Set appWD = CreateObject("Word.Application")
That Word instance has no open documents. You need to open the relevant document and address it via code like:
Set doc = appWD.Documents.Open(Filename:="C:\Users\Aaron Bradow\Documents\Mail Merge Document.docx", AddToRecentFiles:=False, ReadOnly:=True)

The problem is that you create two separate instances of Word Application in the code and try to access a Document instance opened in another Word Application instance/process. If you want to use the ActiveDocument property you need to deal with a single Word Application instance in the code. So, you may pass a created Word Application instance as a parameter to the method to open files.
Be aware, the Documents.Open function from the Word object model opens the specified document and adds it to the Documents collection. It also returns a Document object which can be used instead of the ActiveDocument property in the code.
Sub OpenDoc()
Dim doc As Word.Document
Set doc = Documents.Open FileName:="C:\MyFiles\MyDoc.doc"
End Sub

Related

Using index in VBA

I am trying to select ranges from an excel workbook to paste at certain locations in a word document template. I have a table in sheet 3 that has a column with Table1 then the cell next to it is empty. Table1 is written in the word document in the place where I want table one to be pasted. I have the following code to try and select the range of each table based on the header number of the table and loop through all tables. Any help would be appreciated, If you have another method let me know. This is the code I have so far.
Sub Auto()
Dim cell As Range
Dim rng As Range
Dim wdApp As New Word.Application
Dim wdDoc As Word.Document
Dim wdDoc2 As Word.Document
Dim FilePath As String
Dim FilePath2 As String
Dim ending As String
Dim rngPara As Range
Dim Prompt As String
Dim Filesave As String
Dim FileSave2 As String
Dim CL As Range
Dim rngg As Range
'On Error GoTo ErrorHandler
'FilePath = ThisWorkbook.Path
'FilePath2 = Left(FilePath, InStr(FilePath, "\Calculations") - 1)
'FileName2 = "Disclosures Temps.docx"
'StrDoc = FilePath2 & "\Input" & "\" & FileName2
'Set wdDoc2 = wdApp.Documents.Open(StrDoc)
Set rngPara = Sheet3.Range("A1:Z1058").Find("Table Key")
If rngPara Is Nothing Then
MsgBox "Table Key column was not found."
GoTo ErrorHandler
End If
Set rng = Sheet3.Range(rngPara, rngPara.End(xlDown))
For Each cell In rng
If cell.Value = "" Then Exit For
For i = 6 To Sheet3.Range("TableNumber").Value
rownum = WorksheetFunction.Match(Format(i, "0"), Range("A:A"), 0)
rownend = WorksheetFunction.Match(Format(i + 1, "0"), Range("A:A"), 0) - 1
rowww = rownum & ":" & rownum
coll = WorksheetFunction.Index(Sheet1.Range("4:4") = "", 0)
colnumber = WorksheetFunction.Match(True, WorksheetFunction.Index(Range("4:4") = "", 0), 0) - 1
ColLetter = Split(Cells(1, colnumber).Address, "$")(1)
rng.Cells.Offset(0, 1).Value = "A" & rownum & ":" & ColLetter & rowend
Next i
Next
You can access named ranges/tables in Excel VBA through the worksheets ListObjects collection. Knowing that we can loop through the worksheets and then through the ListObjects property to access each table. From there you can search for a key if you like or you can go off the name of the table instead which might be easier and paste where you want in the Word document.
The example below is meant to be run from the Word document directly but you can adapt to run from Excel instead. The example opens the Excel workbook containing the tables, loops through the worksheets and their ListObjects collection, copies the tables, and pastes them to the bottom of the Word document.
Sub InsertTablesFromExcelToEndOfDocument()
Const strWorkbookPath As String = "C:\temp\search.xlsm" 'the name and path of the workbook
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Dim xlTable As Object
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open(FileName:=strWorkbookPath)
xlApp.Visible = False
For Each xlSheet In xlBook.Worksheets()
For Each xlTable In xlSheet.ListObjects 'Use ListObjects to access Named Table Ranges
Debug.Print "Worksheet Name: " & xlSheet.Name
With xlTable
Debug.Print "-- Table Name: " & .Name
Debug.Print "-- Table Range: " & .Range.Address
Debug.Print ""
.Range.Copy
With ThisDocument.Content
.InsertParagraphAfter
.Paragraphs.Last.Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
End With
End With
Next xlTable
Next xlSheet
Cleanup:
xlApp.Quit
End Sub
Update
The following update is an adjustment to the previous code with some code to search for the table name in the document and paste the corresponding tables there. I went with surrounding the table names with angle brackets just so that it is less likely to mistake real content for the table placeholders
Sub InsertTablesFromExcelAtPlaceholders()
Const strWorkbookPath As String = "C:\temp\search.xlsm" 'the name and path of the workbook
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Dim xlTable As Object
Dim myRange As Range
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open(FileName:=strWorkbookPath)
xlApp.Visible = False
For Each xlSheet In xlBook.Worksheets()
For Each xlTable In xlSheet.ListObjects 'Use ListObjects to access Named Table Ranges
'Debug.Print "Worksheet Name: " & xlSheet.Name
Debug.Print "-- Table Name: " & xlTable.Name
'Debug.Print "-- Table Range: " & xlTable.Range.Address
'Debug.Print ""
Set myRange = ActiveDocument.Content
myRange.Find.Execute FindText:="<" & xlTable.Name & ">"
While myRange.Find.Found = True
xlTable.Range.Copy
myRange.Paste
Set myRange = ActiveDocument.Content
myRange.Find.Execute FindText:="<" & xlTable.Name & ">", Forward:=True
Wend
Next xlTable
Next xlSheet
Cleanup:
xlApp.Quit
End Sub
Can I alter the code to work for a certain range that is not necessarily a table. like I want to specify the range like from the header to the last empty row and from column A to the last empty column. Is this possible?
Sure this is possible, but I would recommend converting the range to a named table instead if possible which would greatly simplify things. You're either defining this range there in the Excel workbook or directly in the code. It's easier to manage if you can define the range and the placeholder outside of the code rather than dipping into the code every time you need to define a new table range.
But back to your question, I think it would be easier to answer if I understood this "Table Key" idea you have. In the code you are looking through what looks like the whole spreadsheet for this "table key" however in your post you say "I have a table in sheet 3 that has a column with Table1 then the cell next to it is empty.". So is your table key actually the first cell in this column you mention? It would be helpful to see an example of the table and this key. If you're interested you can edit your post and add a screenshot or two.

How to find cell value in file names in a folder and open that file? File name contains more characters than cell value

This is the first week I learn vba so bear with me if I have a lot of questions;-)
So I have two folders, one folder contains the templates I need to update, the other contains the reports that the updates will be copied from. Cell A1 in each template contains the code that is specific to that BU. I need vba to find the code in the file names in the report folder and open that report. The problem is that the report names have different lengths, eg. it's named as XXX region_code_XXXXXXXXXXX, there can be any number of "X" before and after the code.
Sub Macro1()
Set fso = CreateObject("scripting.filesystemobject")
Set ff = fso.getfolder("C:\Users\35264\summary\test")
For Each file In ff.Files
Workbooks.Openfile
Set wbk2 = ActiveWorkbook
Sheets("Summary").Select
Range("A1").Select
rngX = Range("A1").Value
Now I need to find rngX in the file names in the report folder... I can't figure out how. Let me know if anyone can help! Thank you!
I am learning how to use dir function. I think it will be helpful to get the names of the reports first.
Combine the FileSystemObject Object With the Dir Function
Dir cannot be used in nested Do...Loops.
Using the FileSystemObject object, it opens files in one folder and uses the information in it to open specific files in another folder by using the Dir function. For each combination, it prints their names to the immediate window and closes each file without saving changes.
A better way to do this would be to write the file paths of the first folder to an array by using the Dir function and then loop through the elements of the array to open each file... etc.
Option Explicit
Sub PrintTemplatesAndReports()
' Templates
Const tFolderPath As String = "C:\Users\35264\summary\templates\"
Const tWorksheetName As String = "Summary"
Const rFilePatternAddress As String = "A1"
Const tFileExtensionLeft As String = "xls"
' Reports
Const rFolderPath As String = "C:\Users\35264\summary\reports\"
Const rFileExtensionPattern As String = ".xls*"
' 1st Worbook (ThisWorkbook)
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(tFolderPath) Then Exit Sub
If Not fso.FolderExists(rFolderPath) Then Exit Sub
Dim fsoFolder As Object: Set fsoFolder = fso.Getfolder(tFolderPath)
' Templates (using the FileSystemObject object)
Dim fsoFile As Object
Dim twb As Workbook, tws As Worksheet
Dim tExtension As String, tFilePath As String
' Report (using Dir)
Dim rwb As Workbook
Dim rFilePattern As String, rFileName As String, rFilePath As String
' Counters
Dim ttCount As Long, tCount As Long, rCount As Long
For Each fsoFile In fsoFolder.Files
ttCount = ttCount + 1
tExtension = fso.GetExtensionName(fsoFile)
If InStr(1, tExtension, tFileExtensionLeft, vbTextCompare) = 1 Then
tCount = tCount + 1
tFilePath = tFolderPath & fsoFile.Name
' 2nd Workbook (Template)
Set twb = Workbooks.Open(tFilePath)
On Error Resume Next
Set tws = twb.Worksheets(tWorksheetName)
On Error GoTo 0
If Not tws Is Nothing Then
rFilePattern = CStr(tws.Range(rFilePatternAddress).Value)
rFileName = Dir(rFolderPath, "*" & rFilePattern _
& "*" & rFileExtensionPattern)
Do Until Len(rFileName) = 0
rCount = rCount + 1
rFilePath = rFolderPath & rFileName
' 3rd Workbook (Report)
Set rwb = Workbooks.Open(rFolderPath, rFileName)
' Do your thing, e.g.:
Debug.Print twb.Name, rwb.Name
rwb.Close SaveChanges:=False
rFileName = Dir ' next report
Loop
Set tws = Nothing
End If
twb.Close SaveChanges:=False
End If
Next fsoFile ' next template
MsgBox "Template files processed: " & tCount & "(" & ttCount & ")" _
& vbLf & "Report files processed: " & rCount & "(" & tCount & ")", _
vbInformation
End Sub

VBA Excel to Word Document: How to Find and Replace ALL

I'm using VBA to search for a given word (Ex, Cell A1) in a Word document, then replace that word in the Word doc with a value that corresponds to the cell beside it (cell B1).
Most instances of the words are only found once in the document, but I have some that repeat throughout. For these repeated ones, only the first instance is replaced and the rest aren't. I tried to find some solutions to this, but I've really only come across Excel-specific ones.
Sub ReplaceAnnual()
'
'
'Declare Variables as Objects
Dim oCell As Integer
Dim from_text As String, to_text As String
Dim WA As Object
Dim ws As Object
Dim wb As Workbook
Dim IntialName As String
Dim fileSaveName As Variant
'Open workbook and setting to the wb object for further use
Set wb = Workbooks.Open("C:\Pathway\Point_Estimates.xlsx")
'Set up Excel Application: sets currently open file as object
Set ws = Workbooks("Point_Estimates")
'Set up Word Application
Set WA = CreateObject("Word.Application")
WA.Visible = True
'Opens Pre-Saved Document & activates it to use
WA.Documents.Open "C:\Pathway\Filename.dotm"
WA.Activate
'Tells which cells to find and replace elements
For oCell = 2 To 75
from_text = Sheets("Values").Range("A" & oCell).Value
to_text = Sheets("Values").Range("B" & oCell).Value
'Specifies which application to work inside
With WA.ActiveDocument
Set myRange = .Content
With myRange.Find
.Execute FindText:=from_text, ReplaceWith:=to_text, Replace:=1
End With
End With
Next oCell
'Activate Excel Worksheet
ws.Activate
'Declare where to find numbers for naming file (e.g. 2020)
InitialName = "Point_Estimates_" & Range("B2")
'Prompt dialog box and save
fileSaveName = Application.GetSaveAsFilename(InitialFileName:=InitialName, _
fileFilter:="Excel Files (*.xls), *.xls")
If fileSaveName <> False Then
MsgBox "Save as " & fileSaveName
End If
'
'
End Sub
It ends with a prompt to save the Excel file with a specified name.
Any tips or help on tweaking this would be greatly appreciated!

VBA - PasteSpecial Error and moving to next row in Excel

I am trying to loop through a number of word documents in a folder, and add some information from the word tables to the excel sheet. Right now I have this:
Private Sub Loop_WordToExcel()
Dim WdApp As Object
Dim wddoc As Object
Dim docName As String
Dim strFile As String
Dim directory As String
directory = "c:\path\to\folder"
strFile = Dir(directory & "*.*")
Set WdApp = CreateObject("Word.Application")
Dim rng As Range
Set rng = Application.InputBox(Prompt:="Enter row", Type:=8)
'Do While strFile <> ""
Set wddoc = WdApp.Documents.Open(Filename:=directory & strFile)
rng.Cells(1) = wddoc.Name
'First Name
wddoc.Tables(1).Cell(1, 3).Range.Copy
rng.Cells(2).PasteSpecial (xlPasteValues)
WdApp.ActiveDocument.Close SaveChanges:=False
strFile = Dir
Loop
End Sub
I have two questions.
1. My first issue is a Run-time error '1004': PasteSpecial method of Range class failed
2. At the end of the loop, how to I advance to the next row for the next word document information to be pasted.
Correct syntax while copying from Word is given, May try
Sub Loop_WordToExcel()
Dim WdApp As Word.Application
Dim WdDoc As Document
Dim docName As String
Dim strFile As String
Dim directory As String
Dim Rng As Range
Dim Offst As Long, Txt As String
directory = "C:\users\user\Desktop\Folder1\" ' Change to your path
strFile = Dir(directory & "*.docx") ' docx extension added to prevent attempt to open other type of files
Set Rng = Application.InputBox(Prompt:="Enter row", Type:=8) '
Set WdApp = CreateObject("Word.Application")
WdApp.Visible = True
Do While strFile <> ""
Set WdDoc = WdApp.Documents.Open(Filename:=directory & strFile)
Rng.Offset(Offst, 0).Value = WdDoc.Name
'First Name
WdDoc.Tables(1).Cell(1, 3).Range.Copy 'will raise error if table& corres cell not exists , My use error handrel
Rng.Offset(Offst, 1).Activate
ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False 'Assumed want get name in Column B
'is is suggested to use the below two lines instead of paste special above three lines
'Txt = WdDoc.Tables(1).Cell(1, 3).Range.Text 'will raise error if table& corres cell not exists , My use error handrel
'Rng.Offset(Offst, 1).Value = Txt
WdDoc.Close SaveChanges:=False
Offst = Offst + 1
strFile = Dir
Loop
WdApp.Quit
End Sub
It is always preferred to add reference of Microsoft Word Object library.

Insert Multiple Bitmap Image into Multiple Worksheet

In my folder, there is AA.bmp, AA.txt, BB.bmp and BB.txt
I am able to extract the data for AA.txt and BB.txt in a separate worksheet.
Am I also able to insert AA.bmp in the same sheet as AA.txt, and BB.bmp in the same sheet as BB.txt?
Sub ExtractData()
iPath = "C:\Users\NHWD78\Desktop\Report\Radiated Immunity\"
ifile = Dir(iPath & "*.txt")
Do While Len(ifile)
Sheets.Add , Sheets(Sheets.Count), , iPath & ifile
ifile = Dir
Range("A10:B10, A16:B19").Copy Destination:=Sheets(Sheets.Count).Range("A1")
Application.CutCopyMode = False
Range("A6:K600").Clear
Columns.AutoFit
Loop
End Sub
I have search throughout the website but only found a way to insert a fixed image with image name.
This will answer your query, its more of a solution than an answer which is not what this site is for, but take the time to read through it as it should be educationally useful too.
You are trying to parse a folder that has content similar to below:-
The result os for these to be in an Excel workbook, with a worksheet containing the text and image for each group (AA, BB, and CC)
First step I would take is to use Microsoft Scripting Runtime, this makes parsing the folder a lot easier. To enable this, within the VBA environment (known as the IDE), select 'Tools' > 'References...', scroll down to 'Microsoft Scripting Runtime' and tick it, then click 'OK' to close the dialog box.
That allows us to the File System Object, which is a very useful file and folder manipulation and interrogation feature set.
Firstly we care most about the *.txt files so lets begin by looping through them:-
Dim FSO As New FileSystemObject
Dim Fldr As Folder
Dim Fl As File
'First we set Fldr to be the folder we care about
Set Fldr = FSO.GetFolder("C:\Users\garye\Desktop\Work")
'Then start a loop to look through each file in the folder
For Each Fl In Fldr.Files
'If the files ends in .txt then we care about it (UCASE used to make it case insensitive)
If Right(UCase(Fl.Name), 4) = ".TXT" Then
'We have found a file
End If
'Do events returns the processor to the system for any other items to be process
'very useful in a loop on a Windows based machine to stop resource hogging and lock ups
DoEvents
Next
Set Fldr = Nothing
Next on the discovery of a text file we want to create a worksheet and import the text. For the sake of this example, it will all be done in a new workbook as well.
Dim WkBk As Workbook
Dim WkBk_Tmp As Workbook
Dim WkSht As Worksheet
Dim WkSht_Tmp As Worksheet
Dim StrName As String
'Create a new workbook
Set WkBk = Application.Workbooks.Add
'...
'Collect the name (i.e. AA from AA.txt)
StrName = Left(Fl.Name, Len(Fl.Name) - 4)
'Create a new worksheet in out new workbook
Set WkSht = WkBk.Worksheets.Add
'Change the worksheet name to the file name
WkSht.Name = StrName
'Open the file in Excel
Set WkBk_Tmp = Application.Workbooks.Open(Fl.Path)
Set WkSht_Tmp = WkBk_Tmp.Worksheets(1)
'Copy its contents into out worksheet
WkSht_Tmp.Cells.Copy WkSht.Cells
Set WkSht_Tmp = Nothing
'Close the file
WkBk_Tmp.Close 0
Set WkBk_Tmp = Nothing
Next we want to insert the image if it is there:-
Dim Rng As Range
'...
'See it a bmp file exists (i.e. AA.bmp)
If FSO.FileExists(Fldr.Path & "\" & StrName & ".bmp") Then
'This get the bottom row of data as a position to insert the image
Set Rng = WkSht.Range(WkSht.Range("A1").End(xlDown).Address).Next(2, 0)
'Add the picture
WkSht.Shapes.AddPicture Fldr.Path & "\" & StrName & ".bmp", msoFalse, msoCTrue, Rng.Left, Rng.Top, -1, -1
Set Rng = Nothing
End If
If we put all the above together it looks as below, hopefully this has been education in what is happening in the code, some good practices, how to approaching a task.
Option Explicit
Sub ExtractData()
Dim FSO As New FileSystemObject
Dim Fldr As Folder
Dim Fl As File
Dim WkBk As Workbook
Dim WkBk_Tmp As Workbook
Dim WkSht As Worksheet
Dim WkSht_Tmp As Worksheet
Dim StrName As String
Dim Rng As Range
'Create a new workbook
Set WkBk = Application.Workbooks.Add
'First we set Fldr to be the folder we care about
Set Fldr = FSO.GetFolder("C:\Users\garye\Desktop\Work")
'Then start a loop to look through each file in the folder
For Each Fl In Fldr.Files
'If the files ends in .txt then we care about it (UCASE used to make it case insensitive)
If Right(UCase(Fl.Name), 4) = ".TXT" Then
'Collect the name (i.e. AA from AA.txt)
StrName = Left(Fl.Name, Len(Fl.Name) - 4)
'Create a new worksheet in out new workbook
Set WkSht = WkBk.Worksheets.Add
'Change the worksheet name to the file name
WkSht.Name = StrName
'Open the file in Excel
Set WkBk_Tmp = Application.Workbooks.Open(Fl.Path)
Set WkSht_Tmp = WkBk_Tmp.Worksheets(1)
'Copy its contents into out worksheet
WkSht_Tmp.Cells.Copy WkSht.Cells
Set WkSht_Tmp = Nothing
'Close the file
WkBk_Tmp.Close 0
Set WkBk_Tmp = Nothing
'See it a bmp file exists (i.e. AA.bmp)
If FSO.FileExists(Fldr.Path & "\" & StrName & ".bmp") Then
'This get the bottom row of data as a position to insert the image
Set Rng = WkSht.Range(WkSht.Range("A1").End(xlDown).Address).Next(2, 0)
'Add the picture
WkSht.Shapes.AddPicture Fldr.Path & "\" & StrName & ".bmp", msoFalse, msoCTrue, Rng.Left, Rng.Top, -1, -1
Set Rng = Nothing
End If
Set WkSht = Nothing
End If
'Do events returns the processor to the system for any other items to be process
'very useful in a loop on a Windows based machine to stop resource hogging and lock ups
DoEvents
Next
Set Fldr = Nothing
Set WkBk = Nothing
MsgBox "Done!"
End Sub
Worksheet.Shapes.AddPicture will do it. Example below: -
Public Sub Sample()
Dim WkBk As Workbook
Dim WkSht As Worksheet
Dim Ole As Object
Set WkBk = ThisWorkbook
Set WkSht = WkBk.Worksheets(1)
WkSht.Shapes.AddPicture "C:\Users\garye\Desktop\AA.bmp", msoFalse, msoCTrue, 0, 0, -1, -1
Set WkSht = Nothing
Set WkBk = Nothing
End Sub

Resources