Excel VBA - modify a macro to hard code file and ranges

[Dont Call me Betty]

Below code resides in Excel file and allows to manually pick a Word file, then manually select two ranges of cells, then does find/replace in the picked Word file

Need to hard code into it:

a) specific file (XYZ.doc) from the same directory Excel file with this code is located
b) the two specific cell ranges: B5:B17 and C5:C17

in order to not to have to manually pick the Word file and manually select those ranges every time, but so that they are picked automatically

Sub replace_texts_range_of_cells_HRD()
'Update by
Dim xWordApp As Word.Application
Dim xDoc As Word.Document
Dim xRng As Range
Dim I As Integer
Dim xFileDlg As FileDialog
On Error GoTo ExitSub
Set xFileDlg = Application.FileDialog(msoFileDialogFilePicker)
xFileDlg.AllowMultiSelect = False
xFileDlg.Filters.Add "Word Document", "*.docx; *.doc; *.docm"
xFileDlg.FilterIndex = 2
If xFileDlg.Show <> -1 Then GoTo ExitSub
Set xRng = Application.InputBox("Please select the lists of find and replace texts (Press Ctrl key to select two same size ranges):", "XXXX says", , , , , , 8)
If xRng.Areas.count <> 2 Then
  MsgBox "Please select two columns (press Ctrl key), the two ranges have the same size.", vbInformation + vbOKOnly, "XXXX says"
  GoTo ExitSub
End If
If (xRng.Areas.Item(1).Rows.count <> xRng.Areas.Item(2).Rows.count) Or _
  (xRng.Areas.Item(1).Columns.count <> xRng.Areas.Item(2).Columns.count) Then
  MsgBox "Please select two columns (press Ctrl key), the two ranges have the same size.", vbInformation + vbOKOnly, "XXXX says"
  GoTo ExitSub
End If
Set xWordApp = CreateObject("Word.application")
xWordApp.Visible = True

Set xDoc = xWordApp.Documents.Open(xFileDlg.SelectedItems.Item(1))
For I = 1 To xRng.Areas.Item(1).Cells.count
  With xDoc.Application.Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = xRng.Areas.Item(1).Cells.Item(I).Value
    .Replacement.Text = xRng.Areas.Item(2).Cells.Item(I).Value
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchByte = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
  End With
  xDoc.Application.Selection.Find.Execute Replace:=wdReplaceAll
Next
ExitSub:
  Set xRng = Nothing
  Set xFileDlg = Nothing
  Set xWordApp = Nothing
  Set xDoc = Nothing
End Sub

 

[DanteAmor]

Try this:

Sub replace_texts_range_of_cells_HRD()
  Dim xWordApp As Word.Application
  Dim xDoc As Word.Document
  Dim rng1 As Range, rng2 As Range
  Dim i As Long
  Dim specificFile As String
  
  specificFile = ThisWorkbook.Path & "\" & "xyz.docx"
  Set rng1 = ActiveSheet.Range("B5:B17")
  Set rng2 = ActiveSheet.Range("C5:C17")
  
  Set xWordApp = CreateObject("Word.application")
  xWordApp.Visible = True
  Set xDoc = xWordApp.Documents.Open(specificFile)
  For i = 1 To rng1.Cells.Count
    With xDoc.Application.Selection.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = rng1.Cells(i).Value
      .Replacement.Text = rng2.Cells(i).Value
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
      .MatchCase = False
      .MatchWholeWord = False
      .MatchByte = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
    End With
    xDoc.Application.Selection.Find.Execute Replace:=wdReplaceAll
  Next
End Sub

Regards
Dante Amor

 

[Dont Call me Betty]

Try this:

Sub replace_texts_range_of_cells_HRD()
  Dim xWordApp As Word.Application
  Dim xDoc As Word.Document
  Dim rng1 As Range, rng2 As Range
  Dim i As Long
  Dim specificFile As String
 
  specificFile = ThisWorkbook.Path & "\" & "xyz.docx"
  Set rng1 = ActiveSheet.Range("B5:B17")
  Set rng2 = ActiveSheet.Range("C5:C17")
 
  Set xWordApp = CreateObject("Word.application")
  xWordApp.Visible = True
  Set xDoc = xWordApp.Documents.Open(specificFile)
  For i = 1 To rng1.Cells.Count
    With xDoc.Application.Selection.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = rng1.Cells(i).Value
      .Replacement.Text = rng2.Cells(i).Value
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
      .MatchCase = False
      .MatchWholeWord = False
      .MatchByte = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
    End With
    xDoc.Application.Selection.Find.Execute Replace:=wdReplaceAll
  Next
End Sub

Regards
Dante Amor

That works well, Thank you! Last thing - How do I then:
a) save that word file into subdirectory named ABC of the same folder where the Excel file containing this macro resides
b) with a file name from cell Z6?

 

[DanteAmor]

a) save that word file into subdirectory named ABC of the same folder where the Excel file containing this macro resides
b) with a file name from cell Z6?

Try:

Sub replace_texts_range_of_cells_HRD()
  Dim xWordApp As Word.Application
  Dim xDoc As Word.Document
  Dim rng1 As Range, rng2 As Range
  Dim i As Long
  Dim specificFile As String, sFolder As String, sFile As String
  
  specificFile = ThisWorkbook.Path & "\" & "xyz.docx"
  Set rng1 = ActiveSheet.Range("B5:B17")
  Set rng2 = ActiveSheet.Range("C5:C17")
  
  Set xWordApp = CreateObject("Word.application")
  xWordApp.Visible = True
  Set xDoc = xWordApp.Documents.Open(specificFile)
  For i = 1 To rng1.Cells.Count
    With xDoc.Application.Selection.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = rng1.Cells(i).Value
      .Replacement.Text = rng2.Cells(i).Value
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
      .MatchCase = False
      .MatchWholeWord = False
      .MatchByte = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
    End With
    xDoc.Application.Selection.Find.Execute Replace:=wdReplaceAll
  Next
  
  'save document
  sFolder = ThisWorkbook.Path & "\" & "ABC" & "\"
  sFile = ActiveSheet.Range("Z6").Value
  xWordApp.ActiveDocument.SaveAs sFolder & sFile & ".docx"
  xWordApp.Quit     'quit word
End Sub

Dante Amor