The below code is copied data from MS Word (content control) to Excel. However, when I copy text with bullet and paste into Excel, it removes the bullets and pastes the text only.
How can I copy bullets from the content control?
Sub getWordFormData()
Dim wdApp As New Word.Application
Dim myDoc As Word.Document
Dim CCtl As Word.ContentControl
Dim myFolder As String, strFile As String
Dim myWkSht As Worksheet, i As Long, j As Long
myFolder = "enter folder path" '<< enter you folder path for the word document
If Dir(myFolder & "\" & "*.*") = "" Then
Application.ScreenUpdating = True
MsgBox "The folder is empty."
Exit Sub
End If
Set myWkSht = ActiveSheet
ActiveSheet.Cells.Clear
Range("A1") = "Test 1"
Range("B1") = "Test 2"
Range("A1:B1").Font.Bold = True
i = myWkSht.Cells(myWkSht.Rows.Count, 1).End(xlUp).Row
strFile = Dir(myFolder & "\*.docx", vbNormal)
While strFile <> ""
i = i + 1
Set myDoc = wdApp.Documents.Open(Filename:=myFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With myDoc
j = 0
For Each CCtl In .ContentControls
j = j + 1
myWkSht.Cells(i, j) = CCtl.Range.Text
Next
myWkSht.Columns.AutoFit
End With
myDoc.Close SaveChanges:=False
strFile = Dir()
Wend
wdApp.Quit
Set myDoc = Nothing: Set wdApp = Nothing: Set myWkSht = Nothing
Application.ScreenUpdating = True
End Sub
try with this block
With myDoc
j = 0
For Each CCtl In .ContentControls
j = j + 1
CCtl.Range.Copy
myWkSht.Cells(i, j).PasteSpecial Paste:=xlPasteValues
Next
myWkSht.Columns.AutoFit
End With
Related
Following the question:
VBA Excel - search multipe terms in workbooks with values matching to them
I would like to make a search for multiple workbooks across the directory, but with specified, repeatable sheets.
The full code:
Sub SearchFolders()
Dim xFso As Object
Dim xFld As Object
Dim xStrSearch As String
Dim xStrPath As String
Dim xStrFile As String
Dim xOut As Worksheet
Dim xWb As Workbook
Dim xWk As Worksheet
Dim xRow As Long
Dim xCol As Long
Dim i As Long
Dim xFound As Range
Dim xStrAddress As String
Dim xFileDialog As FileDialog
Dim xUpdate As Boolean
Dim xCount As Long
Dim xAWB As Workbook
Dim xAWBStrPath As String
Dim xBol As Boolean
Set xAWB = ActiveWorkbook
'Set xWk = ActiveWorkbook.Worksheets("Civils*")
xAWBStrPath = xAWB.Path & "\" & xAWB.Name
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
'xStrSearch = "1366P"
xStrSearch = InputBox("Please provide the BoM Code")
xUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
Set xOut = Worksheets("SUMMARY")
xRow = 1
With xOut
.Cells(xRow, 1) = "Workbook"
.Cells(xRow, 2) = "Worksheet"
.Cells(xRow, 3) = "Cell"
.Cells(xRow, 4) = "Text in Cell"
.Cells(xRow, 5) = "Values corresponding"
Set xFso = CreateObject("Scripting.FileSystemObject")
Set xFld = xFso.GetFolder(xStrPath)
xStrFile = Dir(xStrPath & "\*.xls*")
Do While xStrFile <> ""
xBol = False
If (xStrPath & "\" & xStrFile) = xAWBStrPath Then
xBol = True
Set xWb = xAWB
Else
Set xWb = Workbooks.Open(Filename:=xStrPath & "\" & xStrFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
'Set xWk = Worksheets.Open("Civils Job Order")
End If
'For Each xWk In xWb.Worksheets("Civils Work Order")
For Each xWk In xWb.Worksheets
If xBol And (xWk.Name = .Name) Then
'If xBol And (xWk.Name = "Civils Work Order" Or xWk.Name = "Cable Works Order") Then
Else
Set xFound = xWk.UsedRange.Find(xStrSearch)
If Not xFound Is Nothing Then
xStrAddress = xFound.Address
End If
Do
If xFound Is Nothing Then
Exit Do
Else
xCount = xCount + 1
xRow = xRow + 1
.Cells(xRow, 1) = xWb.Name
.Cells(xRow, 2) = xWk.Name
.Cells(xRow, 3) = xFound.Address
.Cells(xRow, 4) = xFound.Value
.Cells(xRow, 5).Range("A1").Value = xFound.EntireRow.Range("F1").Value
End If
Set xFound = xWk.Cells.FindNext(After:=xFound)
Loop While xStrAddress <> xFound.Address
End If
Next
If Not xBol Then
xWb.Close (False)
End If
xStrFile = Dir
Loop
.Columns("A:E").EntireColumn.AutoFit
End With
MsgBox xCount & " cells have been found", , "BoM Calculator for VM Greenfield"
ExitHandler:
Set xOut = Nothing
Set xWk = Nothing
Set xWb = Nothing
Set xFld = Nothing
Set xFso = Nothing
Application.ScreenUpdating = xUpdate
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
There is no error coming in, but the Excel is frozen indefinitely.
Is it some solution for making this kind of search for the specified worksheet names, which occur regularly across all workbooks in the directory?
This is a bit lengthy, but a lot of the bulk is re-useable functions, so it lets you focus on the logic in the main method.
I'm guessing that the summary sheet is in the same workbook as this code, and that you're scanning a folder for files to summarize, one of which may already be open in Excel (so you don't want to open that again).
Compiles but not tested...
Sub SearchFolders()
Dim wbAct As Workbook, pathMainWb As String, fldrPath As String
Dim bom As String, scrUpdt, wsOut As Worksheet, colFiles As Collection, f As Object
Dim xBol As Boolean, wb As Workbook, ws As Worksheet, arrWs
Dim matchedCells As Collection, cell, numHits As Long, summRow As Long
Set wbAct = ActiveWorkbook
pathMainWb = wbAct.FullName '<<<<
On Error GoTo ErrHandler
fldrPath = UserSelectFolder("Select a folder")
If Len(fldrPath) = 0 Then Exit Sub
'get all files in the selected folder
Set colFiles = GetFileMatches(fldrPath, "*.xls*", False) 'False=no subfolders
If colFiles.Count = 0 Then
MsgBox "No Excel files found in selected folder"
Exit Sub
End If
bom = InputBox("Please provide the BoM Code")
scrUpdt = Application.ScreenUpdating
Application.ScreenUpdating = False
Set wsOut = ThisWorkbook.Worksheets("SUMMARY")
summRow = 1
'sheet names to scan
arrWs = Array("Civils Job Order", "Civils Work Order", "Cable Works Order")
wsOut.Cells(summRow, 1).Resize(1, 5).Value = Array("Workbook", "Worksheet", _
"Cell", "Text in Cell", "Values corresponding")
For Each f In colFiles
xBol = (f.Path = pathMainWb) 'file already open?
If xBol Then
Set wb = wbAct
Else
Set wb = Workbooks.Open(Filename:=f.Path, UpdateLinks:=0, _
ReadOnly:=True, AddToMRU:=False)
End If
For Each ws In wb.Worksheets
'are we interested in this sheet?
If Not IsError(Application.Match(ws.Name, arrWs, 0)) Then
Set matchedCells = FindAll(ws.UsedRange, bom) 'get all cells with bom
If matchedCells.Count > 0 Then
For Each cell In matchedCells
summRow = summRow + 1
wsOut.Cells(summRow, 1).Resize(1, 5).Value = _
Array(wb.Name, ws.Name, cell.Address, cell.Value, _
cell.EntireRow.Range("F1").Value)
numHits = numHits + 1
Next cell 'next match
End If 'any bom matches
End If 'matched sheet name
Next ws
If Not xBol Then wb.Close False 'need to close this workbook?
Next f
wsOut.Columns("A:E").EntireColumn.AutoFit
MsgBox numHits & " cells have been found", , "BoM Calculator for VM Greenfield"
ExitHandler:
Application.ScreenUpdating = scrUpdt
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
'ask the user to select a folder
Function UserSelectFolder(msgPrompt As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = msgPrompt
If .Show = -1 Then UserSelectFolder = .SelectedItems(1) & "\"
End With
End Function
'Return a collection of file objects given a starting folder and a file pattern
' e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function GetFileMatches(startFolder As String, filePattern As String, _
Optional subFolders As Boolean = True) As Collection
Dim fso, fldr, f, subFldr, fpath
Dim colFiles As New Collection
Dim colSub As New Collection
Set fso = CreateObject("scripting.filesystemobject")
colSub.Add startFolder
Do While colSub.Count > 0
Set fldr = fso.getfolder(colSub(1))
colSub.Remove 1
If subFolders Then
For Each subFldr In fldr.subFolders
colSub.Add subFldr.Path
Next subFldr
End If
fpath = fldr.Path
If Right(fpath, 1) <> "\" Then fpath = fpath & "\"
f = Dir(fpath & filePattern) 'Dir is faster...
Do While Len(f) > 0
colFiles.Add fso.getfile(fpath & f)
f = Dir()
Loop
Loop
Set GetFileMatches = colFiles
End Function
'search range `rng` for all matches to `val` and return
' as a Collection of ranges (cells)
Public Function FindAll(rng As Range, val As String) As Collection
Dim rv As New Collection, f As Range
Dim addr As String
Set f = rng.Find(what:=val, after:=rng.Cells(rng.Cells.Count), _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If Not f Is Nothing Then addr = f.Address()
Do Until f Is Nothing
rv.Add f
Set f = rng.FindNext(after:=f)
If f.Address() = addr Then Exit Do
Loop
Set FindAll = rv
End Function
so I have the code bellow (its macro sending emails with mail merge from excel file) and when I run it for the first time it's OK but if I run it for the second time I'm getting the 462 (The remove server machine does not exist or is unavailable). I know that this is caused by occupied variable. But I did everything that I know to prevent this. Could someone tell me how to adjust my code so it can run multiple times without closing the file?
Sub Send_Emails()
Application.ScreenUpdating = False
Dim wrd As Word.Application
Dim Doc1 As Document, Doc2 As Document, Doc3 As Document, Doc4 As Document
Dim StrDoc As String, ListOfDocuments As String
Set wrd = CreateObject("Word.Application")
ListOfDocuments = ThisWorkbook.Path & "\Templates\Germany\Supervisors\ListOfDocuments.docx"
Set Doc1 = wrd.Documents.Open(ListOfDocuments)
With Doc1.MailMerge
If .State = wdMainAndDataSource Then
.Destination = wdSendToNewDocument
.Execute
End If
End With
Set Doc2 = ActiveDocument
ActiveDocument.SaveAs (ThisWorkbook.Path & "\Templates\Germany\Supervisors\Recipients.docx")
Call EmailMergeTableMaker(Doc2)
With Doc2
.SaveAs (ThisWorkbook.Path & "\Templates\Germany\Supervisors\Recipients.docx")
End With
Set Doc3 = Documents.Open(Filename:=ThisWorkbook.Path & "\Templates\Germany\Supervisors\SupervisorEmail.docx", _
AddToRecentFiles:=False)
With Doc3.MailMerge
.MainDocumentType = wdEMail
.OpenDataSource Name:=(ThisWorkbook.Path & "\Templates\Germany\Supervisors\Recipients.docx"), ConfirmConversions:=False, ReadOnly:=False, _
LinkToSource:=True, AddToRecentFiles:=False, Connection:="", SQLStatement:="", _
SQLStatement1:="", SubType:=wdMergeSubTypeOther
If .State = wdMainAndDataSource Then
.Destination = wdSendToNewDocument
.Execute
End If
End With
ActiveDocument.SaveAs (ThisWorkbook.Path & "\Templates\Germany\Supervisors\EmailsToSend.docx")
Set Doc4 = Documents.Open(ThisWorkbook.Path & "\Templates\Germany\Supervisors\EmailsToSend.docx")
Doc3.Close SaveChanges:=False
Set Doc3 = Nothing
Call SendEmailsOutlook
Doc1.Close SaveChanges:=False
Doc2.Close SaveChanges:=False
Doc4.Close SaveChanges:=False
Set Doc1 = Nothing
Set Doc2 = Nothing
Set Doc4 = Nothing
wrd.Quit
Set wrd = Nothing
Application.ScreenUpdating = True
'ThisWorkbook.Close
ThisWorkbook.Saved = True
'Application.Quit
End Sub
Sub SendEmailsOutlook()
Dim oItem As Outlook.MailItem
Dim j As Long
Dim oAccount As Outlook.Account
Dim Source As Document, MailList As Document
Dim Recipient As String, MailListDocument As String, SourceDocument As String
MailListDocument = ThisWorkbook.Path & "\Templates\Germany\Supervisors\Recipients.docx"
SourceDocument = ThisWorkbook.Path & "\Templates\Germany\Supervisors\EmailsToSend.docx"
Set MailList = Documents.Open(MailListDocument)
Set Source = Documents.Open(SourceDocument)
For j = 1 To Source.Sections.Count - 1
Set oItem = CreateObject("Outlook.Application").CreateItem(olMailItem)
For Each oAccount In Outlook.Application.Session.Accounts
If oAccount = "xxxxxx" Then 'xxxxxx
With oItem
'.SentOnBehalfOfName = "xxxxxx"
'.Attachments.Add ThisWorkbook.Path & "xxxxxx"
.Subject = "xxxxxx"
.HTMLBody = Source.Sections(j).Range.Text
Recipient = Left(MailList.Tables(1).Cell(j + 1, 1).Range.Text, Len(MailList.Tables(1).Cell(j + 1, 1).Range.Text) - 1)
If Len(Recipient) < 3 Then Exit For
.SendUsingAccount = oAccount
.To = "xxxxxx"
'.To = Recipient
.Send
End With
Set oItem = Nothing
End If
Next
Next j
End Sub
Sub EmailMergeTableMaker(DocName As Document)
Dim oTbl As Object
Dim i As Integer, j As Integer
Dim oRow As Object
Dim oRng As Object
Dim strTxt As String
With DocName
.Paragraphs(1).Range.Delete
Call TableJoiner
For Each oTbl In .Tables
j = 4
With oTbl
i = .Columns.Count - j
For Each oRow In .Rows
Set oRng = oRow.Cells(j).Range
With oRng
.MoveEnd Unit:=wdCell, Count:=i
.Cells.Merge
strTxt = Replace(.Text, vbCr, vbTab)
On Error Resume Next
If Len(strTxt) > 1 Then .Text = Left(strTxt, Len(strTxt) - 2)
End With
Next
End With
Next
For Each oTbl In .Tables
For i = 1 To j
oTbl.Columns(i).Cells.Merge
Next
Next
With .Tables(1)
.Rows.Add BeforeRow:=.Rows(1)
.Cell(1, 1).Range.Text = "Recipient"
.Cell(1, 2).Range.Text = "Name"
.Cell(1, 3).Range.Text = "Gender"
.Cell(1, 4).Range.Text = "List"
End With
.Paragraphs(1).Range.Delete
Call TableJoiner
End With
Set oRng = Nothing
End Sub
Private Sub TableJoiner()
Dim wrd2 As Object, doc As Object, tbl As Object
Dim oTbl As Table
Set wrd2 = GetObject(, "Word.Application")
Set doc = wrd2.Documents.Open(ThisWorkbook.Path & "\Templates\Germany\Supervisors\Recipients.docx")
For Each tbl In doc.Tables
With tbl.Range.Next
If .Information(wdWithInTable) = False Then .Delete
End With
Next
Set wrd = Nothing
End Sub
Thank for any suggestions!
I have written a macro that would bring values of certain field from a word file and insert it in a excel file. On every alternate run the word macro gives an error "object variable or with block variable not set". Please help me.
Sub getWordFormData()
Dim exApp As Object, myDoc As Object
Dim myFolder As String, strFile As String
Dim excelApp As Object
Dim openExcel As Workbook
myFolder = ActiveDocument.Path
If Len((myFolder)) = 0 Then
MsgBox myFolder & vbCrLf & "Not Found", vbInformation, "Cancelled - getWordFormData"
End If
Application.ScreenUpdating = False
Set exApp = CreateObject("Word.Application")
Set myDoc = ActiveWorkbook
Set excelApp = New Excel.Application
Set openExcel = excelApp.Workbooks.Open("F:\VBA Sample projects\word to excel\Proposal_DB.xlsx")
excelApp.Visible = True
excelApp.Range("A1").End(xlDown).Offset(1, 0).Select
Set myDoc = exApp.Documents.Open(FileName:=myFolder & "\" & "TEMPLATE WORD.docx", ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
With excelApp
.Cells(ActiveCell.Row, 1).Value = myDoc.SelectContentControlsByTag("date").Item(1).Range.Text
.Cells(ActiveCell.Row, 2).Value = myDoc.SelectContentControlsByTag("ProtocolNo.").Item(1).Range.Text
.Cells(ActiveCell.Row, 3).Value = myDoc.SelectContentControlsByTag("Subject").Item(1).Range.Text
'excelApp.Cells(ActiveCell.Row, 4).Value = myDoc.SelectContentControlsByTag("companyname").Item(1).Range.Text
'excelApp.Cells(ActiveCell.Row, 5).Value = myDoc.SelectContentControlsByTag("customer_name").Item(1).Range.Text
'excelApp.Cells(Nextrow.Row, 6).Value = myDoc.SelectContentControlsByTag("total_amount").Item(1).Range.Text
'excelApp.Cells(Nextrow.Row, 7).Value = myDoc.SelectContentControlsByTag("employee_name").Item(1).Range.Text
End With
myDoc.Close SaveChanges:=False
' strFile = Dir()
'Wend
excelApp.Quit
Application.ScreenUpdating = True
'End With
'exApp.Quit
End Sub
Compiled but not tested:
'add a reference to the Microsoft Excel objectl ibary in your VBA project
Sub getWordFormData()
Dim myDoc As Document
Dim myFolder As String, strFile As String
Dim excelApp As Excel.Application
Dim excelWb As Excel.Workbook, rw As Excel.Range
myFolder = ActiveDocument.Path
If Len(myFolder) = 0 Then
MsgBox myFolder & vbCrLf & " Not Found", vbInformation, "Cancelled - getWordFormData"
Exit Sub
End If
'create Excel application and open the workbook
Set excelApp = New Excel.Application
excelApp.Visible = True
Set excelWb = excelApp.Workbooks.Open("F:\VBA Sample projects\word to excel\Proposal_DB.xlsx")
'get the next empty row in the worksheet
With excelWb.Sheets(1) '<< or use a specific sheet name
Set rw = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow
End With
'you don't need a separate Word instance to open this document...
Set myDoc = Documents.Open(FileName:=myFolder & "\" & "TEMPLATE WORD.docx", _
ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
rw.Cells(1).Value = myDoc.SelectContentControlsByTag("date").Item(1).Range.Text
rw.Cells(2).Value = myDoc.SelectContentControlsByTag("ProtocolNo.").Item(1).Range.Text
rw.Cells(3).Value = myDoc.SelectContentControlsByTag("Subject").Item(1).Range.Text
myDoc.Close savechanges:=False
excelWb.Close savechanges:=True
excelApp.Quit
End Sub
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 first create files in Excel. This macro saves all sheets into separate tab delimited text files.
How can I save with a tilde "~" instead of a tab?
Sub newworkbooks()
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = ActiveWorkbook.Path & "\" & _
Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' End With
On Error Resume Next '<< a folder exists
MkDir MyFilePath '<< create a folder
For N = 1 To Sheets.Count
Sheets(N).Activate
SheetName = ActiveSheet.Name
Cells.Copy
Workbooks.Add (xlWBATWorksheet)
With ActiveWorkbook
With .ActiveSheet
.Paste
.Name = SheetName
[A1].Select
End With
'save book in this folder
.saveas Filename:=MyFilePath _
& "\PO" & SheetName & ".txt", FileFormat:=xlTextWindows
.Close SaveChanges:=True
End With
.CutCopyMode = False
Next
End With
Sheet1.Activate
End Sub
Instead of looking like the following
this is a test
it should look like this
this~is~a~test
Here's one approach, which would be easy to modify to suit - this gives you control over the character set and the delimiter:
https://excel.solutions/2014/04/using-vba-write-excel-data-to-text-file/
Sub WriteTextFile()
Dim rng As Range, lRow As Long
Dim stOutput As String, stNextLine As String, stSeparator As String
Dim stFilename As String, stEncoding As String
Dim fso As Object
'-------------------------------------------------------------------------------------
'CHANGE THESE PARAMETERS TO SUIT
Set rng = ActiveSheet.UsedRange 'this is the range which will be written to text file
stFilename = "C:\Temp\TextOutput.txt" 'this is the text file path / name
stSeparator = vbTab 'e.g. for comma seperated value, change this to ","
stEncoding = "UTF-8" 'e.g. "UTF-8", "ASCII"
'-------------------------------------------------------------------------------------
For lRow = 1 To rng.Rows.Count
If rng.Columns.Count = 1 Then
stNextLine = rng.Rows(lRow).Value
Else
stNextLine = Join$(Application.Transpose(Application.Transpose(rng.Rows(lRow).Value)), stSeparator)
End If
If stOutput = "" Then
stOutput = stNextLine
Else
stOutput = stOutput & vbCrLf & stNextLine
End If
Next lRow
Set fso = CreateObject("ADODB.Stream")
With fso
.Type = 2
.Charset = stEncoding
.Open
.WriteText stOutput
.SaveToFile stFilename, 2
End With
Set fso = Nothing
End Sub
I'm sure you could adapt that to loop through your worksheets, and output the UsedRange of each.
EDIT:
Here's how to adapt it to use tilde as separator, and loop through each worksheet;
Sub OutputAllSheetsTildeSeparated()
Dim rng As Range, lRow As Long
Dim stOutput As String, stNextLine As String, stSeparator As String
Dim stFilepath As String, stFilename As String, stEncoding As String
Dim ws As Worksheet
Dim fso As Object
stFilepath = ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
stSeparator = "~"
stEncoding = "UTF-8"
If Dir(stFilepath, vbDirectory) = vbNullString Then MkDir stFilepath
For Each ws In ThisWorkbook.Worksheets
Set rng = ws.UsedRange
stFilename = stFilepath & "\PO" & ws.Name & ".txt"
For lRow = 1 To rng.Rows.Count
If rng.Columns.Count = 1 Then
stNextLine = rng.Rows(lRow).Value
Else
stNextLine = Join$(Application.Transpose(Application.Transpose(rng.Rows(lRow).Value)), stSeparator)
End If
If stOutput = "" Then
stOutput = stNextLine
Else
stOutput = stOutput & vbCrLf & stNextLine
End If
Next lRow
Set fso = CreateObject("ADODB.Stream")
With fso
.Type = 2
.Charset = stEncoding
.Open
.WriteText stOutput
.SaveToFile stFilename, 2
End With
Set fso = Nothing
Next ws
End Sub