#16
|
||||
|
||||
If you're always processing only a single folder, you can replace:
Code:
strFolder = GetFolder If strFolder = "" Then Exit Sub strFile = Dir(strFolder & "\*.doc", vbNormal) Code:
strFolder = "My file path \*.doc", vbNormal) Code:
Function GetFolder() As String Dim oFolder As Object GetFolder = "" Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0) If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path Set oFolder = Nothing Note: Do not put the document holding the macro into the same folder as the files to be processed.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#17
|
|||
|
|||
hello dears
whin i run this macro i got Run-time error '5624. code ---- Code:
Sub demo() Application.ScreenUpdating = True Dim strFolder As String, strFile As String, wdDoc As Document Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String Dim bStrt As Boolean, iDataRow As Long, bFound As Boolean Dim xlFList As String, xlRList As String, i As Long, Rslt ' modify code to make .xls as relative path Dim My_Path As String My_Path = Applicatio StrWkBkNm = My_path & "\table.xls" StrWkSht = "list" If Dir(StrWkBkNm) = "" Then MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation Exit Sub End If 'Get the folder to process strFolder = GetFolder If strFolder = "" Then Exit Sub strFile = Dir(strFolder & "\*.doc", vbNormal) ' Test whether Excel is already running. On Error Resume Next bStrt = False ' Flag to record if we start Excel, so we can close it later. Set xlApp = GetObject(, "Excel.Application") 'Start Excel if it isn't running If xlApp Is Nothing Then Set xlApp = CreateObject("Excel.Application") If xlApp Is Nothing Then MsgBox "Can't start Excel.", vbExclamation Exit Sub End If ' Record that we've started Excel. bStrt = True End If On Error GoTo 0 'Check if the workbook is open. bFound = False With xlApp 'Hide our Excel session If bStrt = True Then .Visible = False For Each xlWkBk In .Workbooks If xlWkBk.FullName = StrWkBkNm Then ' It's open Set xlWkBk = xlWkBk bFound = True Exit For End If Next ' If not open by the current user. If bFound = False Then ' Check if another user has it open. If IsFileLocked(StrWkBkNm) = True Then ' Report and exit if true MsgBox "The Excel workbook is in use." & vbCr & "Please try again later.", vbExclamation, "File in use" If bStrt = True Then .Quit Exit Sub End If ' The file is available, so open it. Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm) If xlWkBk Is Nothing Then MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation If bStrt = True Then .Quit Exit Sub End If End If ' Process the workbook. With xlWkBk.Worksheets(StrWkSht) ' Find the last-used row in column A. ' Add 1 to get the next row for data-entry. iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp ' Output the captured data. For i = 1 To iDataRow ' Skip over empty fields to preserve the underlying cell contents. If Trim(.Range("A" & i)) <> vbNullString Then xlFList = xlFList & "|" & Trim(.Range("A" & i)) xlRList = xlRList & "|" & Trim(.Range("B" & i)) End If Next End With If bFound = False Then xlWkBk.Close False If bStrt = True Then .Quit End With ' Release Excel object memory Set xlWkBk = Nothing: Set xlApp = Nothing 'Process each document in the folder While strFile <> "" Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False) 'Process each word from the F/R List For i = 1 To UBound(Split(xlFList, "|")) With wdDoc.Range With .Find .ClearFormatting .Replacement.ClearFormatting ' .MatchWholeWord = True .MatchCase = True .Wrap = wdFindStop .Font.Name = "tahoma" .Text = Split(xlFList, "|")(i) .Replacement.Font.Name = "black br" .Replacement.Text = Split(xlRList, "|")(i) ' debugger show this line .Execute Replace:=wdReplaceAll End With End With Next 'Close the document wdDoc.Close SaveChanges:=True MsgBox "document saved" 'Get the next document strFile = Dir() Wend Application.ScreenUpdating = True End Sub Function GetFolder() As String Dim oFolder As Object GetFolder = "" Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0) If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path Set oFolder = Nothing End Function Function IsFileLocked(strFileName As String) As Boolean On Error Resume Next Open strFileName For Binary Access Read Write Lock Read Write As #1 Close #1 IsFileLocked = Err.Number Err.Clear End Function Last edited by macropod; 03-12-2017 at 06:12 AM. Reason: Added code tags |
#18
|
||||
|
||||
You have a bleedingly obvious error with:
My_Path = Applicatio PS: When posting code, please use the code tags, indicated by the # button on the posting menu. Without them, your code loses much of whatever structure it had.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#19
|
|||
|
|||
runtime errowr
hello macropod sorry i just was using basic text format, when i run this macro i got Run-time error '5624. in below code i marked the line which make this, but i not able to fix it so hope you will help me. Code:
Sub Demo() Application.ScreenUpdating = False Dim strFolder As String, strFile As String, wdDoc As Document Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String Dim bStrt As Boolean, iDataRow As Long, bFound As Boolean Dim xlFList As String, xlRList As String, i As Long, Rslt 'Relative path Dim My_Path As String My_Path = Application.ActiveDocument.Path StrWkBkNm = My_Path & "\Table.xls" StrWkSht = "list" If Dir(StrWkBkNm) = "" Then MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation Exit Sub End If 'Get the folder to process strFolder = GetFolder If strFolder = "" Then Exit Sub strFile = Dir(strFolder & "\*.doc", vbNormal) ' Test whether Excel is already running. On Error Resume Next bStrt = False ' Flag to record if we start Excel, so we can close it later. Set xlApp = GetObject(, "Excel.Application") 'Start Excel if it isn't running If xlApp Is Nothing Then Set xlApp = CreateObject("Excel.Application") If xlApp Is Nothing Then MsgBox "Can't start Excel.", vbExclamation Exit Sub End If ' Record that we've started Excel. bStrt = True End If On Error GoTo 0 'Check if the workbook is open. bFound = False With xlApp 'Hide our Excel session If bStrt = True Then .Visible = False For Each xlWkBk In .Workbooks If xlWkBk.FullName = StrWkBkNm Then ' It's open Set xlWkBk = xlWkBk bFound = True Exit For End If Next ' If not open by the current user. If bFound = False Then ' Check if another user has it open. If IsFileLocked(StrWkBkNm) = True Then ' Report and exit if true MsgBox "The Excel workbook is in use." & vbCr & "Please try again later.", vbExclamation, "File in use" If bStrt = True Then .Quit Exit Sub End If ' The file is available, so open it. Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm) If xlWkBk Is Nothing Then MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation If bStrt = True Then .Quit Exit Sub End If End If ' Process the workbook. With xlWkBk.Worksheets(StrWkSht) ' Find the last-used row in column A. ' Add 1 to get the next row for data-entry. iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp ' Output the captured data. For i = 1 To iDataRow ' Skip over empty fields to preserve the underlying cell contents. If Trim(.Range("A" & i)) <> vbNullString Then xlFList = xlFList & "|" & Trim(.Range("A" & i)) xlRList = xlRList & "|" & Trim(.Range("B" & i)) End If Next End With If bFound = False Then xlWkBk.Close False If bStrt = True Then .Quit End With ' Release Excel object memory Set xlWkBk = Nothing: Set xlApp = Nothing 'Process each document in the folder While strFile <> "" Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False) 'Process each word from the F/R List For i = 1 To UBound(Split(xlFList, "|")) With wdDoc.Range With .Find .ClearFormatting .Replacement.ClearFormatting ' .MatchWholeWord = True .MatchCase = True .Wrap = wdFindStop 'Set font name .Font.Name = "Tahoma" .Text = Split(xlFList, "|")(i) .Replacement.Font.Name = "Times new roman" .Replacement.Text = Split(xlRList, "|")(i) ' Debugger runtime errowr in below line: ' .Execute Replace:=wdReplaceAll End With End With Next 'Close the document wdDoc.Close SaveChanges:=True MsgBox "document saved" 'Get the next document strFile = Dir() Wend Application.ScreenUpdating = False ' MsgBox "font conversion done" End Sub Function GetFolder() As String Dim oFolder As Object GetFolder = "" Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0) If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path Set oFolder = Nothing End Function Function IsFileLocked(strFileName As String) As Boolean On Error Resume Next Open strFileName For Binary Access Read Write Lock Read Write As #1 Close #1 IsFileLocked = Err.Number Err.Clear End Function |
#20
|
||||
|
||||
On which like are you getting the error? Have you checked the contents of whatever variables are in use at that point?
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#21
|
|||
|
|||
dear macropod
i have excel list contains all letters and its replacement the errowr in this line .Execute Replace:=wdReplaceAll and notice that the document all letters and font not change which means that errowr before find and replacement excute any ideas will be great thanks |
#22
|
||||
|
||||
What is the 'Find' text and 'Replace' text when the error occurs?
And, since you are specifying the Find and Replace fonts, your Find/Replace code should include the line: .Format = True You should also replace: .Wrap = wdFindStop with: .Wrap = wdFindContinue
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#23
|
|||
|
|||
dear macropod
the senario, that in excel file A: find B: replace macro run once open .doc file errowr occurs curser in .doc file not highlite any text i tried your suggested code with and without .clearFormatting am i need to run it in office 2010 or higher? Code:
With wdDoc.Range With .Find .ClearFormatting .format = true .Replacement.ClearFormatting .format = true .MatchCase = True .Wrap = wdFindContinue 'Set font name .Font.Name = "Tahoma" .Text = Split(xlFList, "|")(i) .Replacement.Font.Name = "Times new roman" .Replacement.Text = Split(xlRList, "|")(i) ' Debugger runtime errowr in below line: ' .Execute Replace:=wdReplaceAll End With End With thanks very much |
#24
|
||||
|
||||
I am quite aware of that, but it doesn't answer my question. What do Split(xlFList, "|")(i) and Split(xlRList, "|")(i) show when you move the mouse over them when the error occurs?
No. Furthermore, most people have no problems at all using the code...
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#25
|
|||
|
|||
unfortiontly i use screenreader so we've some issues in debugging
i never use mouse so, could u run it and see? am so sorry for this request |
#26
|
||||
|
||||
Since I have neither your Excel workbook nor any of the content you're trying to process, it would be futile for me to run the macro.
Besides which, I have told you what changes you should make to the code and you keep suggesting other changes - without any understanding of their effect. Everything would probably work just fine if you stopped messing with the code...
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#27
|
|||
|
|||
Quote:
thanks very much |
#28
|
|||
|
|||
attached files
evening dear here attached files for macro and test document also sample for excel list. am really thanks very much for your time and effort with me. |
#29
|
|||
|
|||
dear macropod
the code in attached sample run normally without issues after i reinstall office but if set font name and format = true it do nothing but work perfect if delete font name and formate true so do you think that wrd 2003 not support font name in find and replace? thanks |
#30
|
||||
|
||||
I get no errors with the code in your attachment. That said it also doesn't work, because you need to use .Font.NameAscii instead of .Font.Name. Try:
Code:
Sub Demo() Application.ScreenUpdating = False Dim strFolder As String, strFile As String, wdDoc As Document Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String Dim bStrt As Boolean, iDataRow As Long, bFound As Boolean Dim xlFList As String, xlRList As String, i As Long StrWkBkNm = Application.ActiveDocument.Path & "\FrTable.xls" StrWkSht = "list" If Dir(StrWkBkNm, vbNormal) = "" Then MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation Exit Sub End If 'Get the folder to process strFolder = GetFolder If strFolder = "" Then Exit Sub strFile = Dir(strFolder & "\*.doc", vbNormal) ' Test whether Excel is already running. On Error Resume Next bStrt = False ' Flag to record if we start Excel, so we can close it later. Set xlApp = GetObject(, "Excel.Application") 'Start Excel if it isn't running If xlApp Is Nothing Then Set xlApp = CreateObject("Excel.Application") If xlApp Is Nothing Then MsgBox "Can't start Excel.", vbExclamation Exit Sub End If ' Record that we've started Excel. bStrt = True End If On Error GoTo 0 'Check if the workbook is open. bFound = False With xlApp 'Hide our Excel session If bStrt = True Then .Visible = False For Each xlWkBk In .Workbooks If xlWkBk.FullName = StrWkBkNm Then ' It's open Set xlWkBk = xlWkBk bFound = True Exit For End If Next ' If not open by the current user. If bFound = False Then ' Check if another user has it open. If IsFileLocked(StrWkBkNm) = True Then ' Report and exit if true MsgBox "The Excel workbook is in use." & vbCr & "Please try again later.", vbExclamation, "File in use" If bStrt = True Then .Quit Exit Sub End If ' The file is available, so open it. Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm) If xlWkBk Is Nothing Then MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation If bStrt = True Then .Quit Exit Sub End If End If ' Process the workbook. With xlWkBk.Worksheets(StrWkSht) ' Find the last-used row in column A. ' Add 1 to get the next row for data-entry. iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp ' Output the captured data. For i = 1 To iDataRow ' Skip over empty fields to preserve the underlying cell contents. If Trim(.Range("A" & i)) <> vbNullString Then xlFList = xlFList & "|" & Trim(.Range("A" & i)) xlRList = xlRList & "|" & Trim(.Range("B" & i)) End If Next End With If bFound = False Then xlWkBk.Close False If bStrt = True Then .Quit End With ' Release Excel object memory Set xlWkBk = Nothing: Set xlApp = Nothing 'Process each document in the folder While strFile <> "" Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False) 'Process each word from the F/R List For i = 1 To UBound(Split(xlFList, "|")) MsgBox Split(xlFList, "|")(i) & vbTab & Split(xlRList, "|")(i) With wdDoc.Range With .Find .ClearFormatting .Replacement.ClearFormatting .Format = True .Forward = True .MatchCase = True .MatchWholeWord = False .Wrap = wdFindContinue .Font.NameAscii = "Tahoma" .Replacement.Font.NameAscii = "Times New Roman" .Text = Split(xlFList, "|")(i) .Replacement.Text = Split(xlRList, "|")(i) .Execute Replace:=wdReplaceAll If .Found Then MsgBox "!" End With End With Next 'Close the document wdDoc.Close SaveChanges:=True 'Get the next document strFile = Dir() Wend Application.ScreenUpdating = False End Sub
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Macro to replace digits with letters | Bananabean | Word VBA | 6 | 09-14-2013 09:28 PM |
How to replace all font occurencies by another (e.g. Arial-->Courier) | pstein | Word | 1 | 04-30-2013 05:58 AM |
Find and Replace maintain format | winningson | Word | 3 | 01-19-2013 05:38 AM |
Format Font | herbhh | Word | 10 | 05-23-2011 08:29 AM |
How do I import text columns with specified spacing between words w/o losing format? | Fucius | Word | 0 | 08-09-2010 06:23 PM |