Need Help Combining 2 VBA codes - vba

Question

I need to combine these two VBA Codes the first is finding and replacing multi items in one document and the second find and replaces a word throughout an entire folder. As you can imagine I need to find and replace multiple words in each document in the folder with 1 button.
CODE 1:
Sub FindAndReplaceMultiItems()
Dim strFindText As String
Dim strReplaceText As String
Dim nSplitItem As Long
Application.ScreenUpdating = False
' Enter items to be replaces and new ones.
strFindText = InputBox("Enter items to be found here,seperated by comma: ", "Items to be found")
strReplaceText = InputBox("Enter new items here, seperated by comma: ", "New items")
nSplitItem = UBound(Split(strFindText, ","))
' Find each item and replace it with new one respectively.
For nSplitItem = 0 To nSplitItem
With Selection
.HomeKey Unit:=wdStory
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = Split(strFindText, ",")(nSplitItem)
.Replacement.Text = Split(strReplaceText, ",")(nSplitItem)
.Format = False
.MatchWholeWord = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End With
Next nSplitItem
Application.ScreenUpdating = True
End Sub
CODE 2:
Sub FindAndReplaceInFolder()
Dim objDoc As Document
Dim strFile As String
Dim strFolder As String
Dim strFindText As String
Dim strReplaceText As String
' Pop up input boxes for user to enter folder path, the finding and replacing texts.
strFolder = InputBox("C:\Users\freil\AppData\Local\Packages\Microsoft.MicrosoftEdge_8wekyb3d8bbwe\TempState\Downloads\Agreements Folder:")
strFile = Dir(strFolder & "\" & "*.docx", vbNormal)
strFindText = InputBox("Find:")
strReplaceText = InputBox("Replace:")
' Open each file in the folder to search and replace texts. Save and close the file after the action.
While strFile <> ""
Set objDoc = Documents.Open(FileName:=strFolder & "\" & strFile)
With objDoc
With Selection
.HomeKey Unit:=wdStory
With Selection.Find
.Text = strFindText
.Replacement.Text = strReplaceText
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End With
objDoc.Save
objDoc.Close
strFile = Dir()
End With
Wend
End Sub

Answer 1

Welcome to SO. You just need to encompass While strFile <> "" loop (and related variables etc) from Code 2 around Code 1 For loop. However there are other issues with code. May try
Sub FindAndReplaceMultiItems()
Dim strFindText As String
Dim strReplaceText As String
Dim nSplitItem As Long, i As Long
Dim strFolder As String, StrFile As String
Dim objDoc As Document
'Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = -1 Then
strFolder = .SelectedItems(1)
End If
End With
If Len(strFolder) = 0 Then
MsgBox " No folder Selected"
Exit Sub
End If
strFindText = InputBox("Enter items to be found here,seperated by comma: ", "Items to be found", "asdf,qwert,zxc")
If Len(strFindText) = 0 Then
MsgBox " No Find Text Entered"
Exit Sub
End If
strReplaceText = InputBox("Enter new items here, seperated by comma: ", "New items", "0000000000,1111111111,222222222222")
If Len(strReplaceText) = 0 Then
MsgBox " No Replace Text Entered"
Exit Sub
End If
nSplitItem = UBound(Split(strFindText, ","))
If nSplitItem <> UBound(Split(strReplaceText, ",")) Then
MsgBox " Unequal Numbers of Find & Replacement Text"
Exit Sub
End If
StrFile = Dir(strFolder & "\" & "*.docx", vbNormal)
'Open each file in the folder to search and replace texts. Save and close the file after the action.
While StrFile <> ""
Set objDoc = Documents.Open(FileName:=strFolder & "\" & StrFile)
objDoc.Select
' Find each item and replace it with new one respectively.
For i = 0 To nSplitItem
With Selection
.HomeKey Unit:=wdStory
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = Split(strFindText, ",")(i)
.Replacement.Text = Split(strReplaceText, ",")(i)
.Format = False
.MatchWholeWord = False
.Execute Replace:=wdReplaceAll
End With
End With
Next i
'objDoc.Save
objDoc.Close True
StrFile = Dir()
Wend
'Application.ScreenUpdating = True
End Sub

Answer 2

Try something along the lines of:
Sub BulkFindReplace()
Application.ScreenUpdating = False
Dim Doc As Document, strFolder As String, strFile As String, i As Long
Const FList As String = "One,Two,Three"
Const RList As String = "Four,Five,Six"
StrFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
'Loop through all documents in the chosen folder
While strFile <> ""
Set Doc = Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With Doc
With .Range.Find
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
'Process each word from the Find/Replace Lists
For i = 0 To UBound(Split(FList, ","))
.Text = Split(FList, ",")(i)
.Replacement.Text = Split(RList, ",")(i)
.Execute Replace:=wdReplaceAll
Next
End With
.Close SaveChanges:=True
End With
strFile = Dir()
Wend
Set Doc = Nothing
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