Попытка найти / заменить символом подстановки - PullRequest
0 голосов
/ 14 ноября 2018

Я пытаюсь перебрать все текстовые файлы в папке, открыть каждый, найти / заменить, сохранить каждый и закрыть каждый.Мой код выглядит следующим образом.

Sub FindAndReplaceText()

 Dim FileName As String
 Dim FolderPath As String
 Dim FSO As Object
 Dim I As Integer
 Dim SearchForWords As Variant
 Dim SubstituteWords As Variant
 Dim Text As String
 Dim TextFile As Object

  'Change these arrays to word you want to find and replace
  SearchForWords = Array("  steps:" & "*" & "        fields:")
  SubstituteWords = Array("  global" & vbCrLf & "    global:" & vbCrLf & "      schema_def:" & vbCrLf & "        fields:")

  'Change the folder path to where your text files are.
  ' look for all lines with: '      - .*Pricing_RealEstate' & '*'
   FolderPath = "C:\path_here\"

     Set FSO = CreateObject("Scripting.FileSystemObject")

     FolderPath = IIf(Right(FolderPath, 1) <> "\", FolderPath & "\", FolderPath)
     FileName = Dir(FolderPath & "\*.txt")

     Do While FileName <> ""
       FileSpec = FolderPath & FileName
        'Read all the file's text into a string variable.
         Set TextFile = FSO.OpenTextFile(FileSpec, 1, False)
           Text = TextFile.ReadAll
         TextFile.Close

        'Scan the string for words to replace and write the string back to the file.
         Set TextFile = FSO.OpenTextFile(FileSpec, 2, False)
           For I = 0 To UBound(SearchForWords)
           Debug.Print Text
             Replace Text, SearchForWords(I), SubstituteWords(I)
           Debug.Print Text
           Next I
         TextFile.Write Text
         TextFile.Close
       FileName = Dir()
     Loop

End Sub

1 Ответ

0 голосов
/ 15 ноября 2018

Конечно, это не ответ «Попытка найти / заменить с подстановочными знаками» и может показаться грубым и детским для экспертов вашего роста.Но он опробован и работает с образцами данных, поэтому, возможно, не помечу и не проголосую.

Sub FindAndReplaceText2()
 Dim FileName, FileName2 As String
 Dim FolderPath, FolderPath2 As String
 Dim FileSpec, FileSpec2 As String
 Dim FSO As Object
 Dim SearchForWords As String
 Dim SubstituteWords As String
 Dim Text As String
 Dim TextFile As Object

  'Change these arrays to word you want to find and replace
  SearchForWords = "  steps:" & "*" & "        fields:"
  SubstituteWords = "  global" & vbCrLf & "    global:" & vbCrLf & "      schema_def:" & vbCrLf & "        fields:"


  'Change the folder path to where your text files are.
  ' look for all lines with: '      - .*Pricing_RealEstate' & '*'
   FolderPath = "C:\users\user\Desktop\New Folder\"
   FolderPath2 = "C:\users\user\Desktop\New Folder2\"
   Set FSO = CreateObject("Scripting.FileSystemObject")
   FileName = Dir(FolderPath & "\*.txt")

     Do While FileName <> ""
       FileSpec = FolderPath & FileName
       FileSpec2 = FolderPath2 & FileName

        'Read all the file's text into a string variable.
         Set TextFile = FSO.OpenTextFile(FileSpec, 1, False)
         Text = TextFile.ReadAll
         TextFile.Close
         'SrchReplText Now  work for single wildcard only
         Text = SrchReplText(Text, SearchForWords, SubstituteWords)
        'Scan the string for words to replace and write the string back to the file.
         Set TextFile = FSO.CreateTextFile(FileSpec2, 2, False)
         TextFile.Write Text
         TextFile.Close
     FileName = Dir()
     Loop
End Sub

Private Function SrchReplText(Txt As String, SrcTxt As String, RplTxt As String) As Variant
'Now for single wildcard only using single loop
Dim Wordx, Word3 As Variant
Dim I, I2 As Long
SrchReplText = Txt
Wordx = Split(SrcTxt, "*")
If UBound(Wordx) > 1 Then Exit Function
If UBound(Wordx) = 1 Then
Do
  Found = False
  I = InStr(1, SrchReplText, Wordx(0))
  If I > 0 Then I2 = InStr(I, SrchReplText, Wordx(1))
     If I > 0 And I2 > 0 Then
     Found = True
     Word3 = Mid(SrchReplText, I, I2 - I + Len(Wordx(1)))
     SrchReplText = Replace(SrchReplText, Word3, RplTxt, 1, 1)
     End If
Loop While Found
Else
SrchReplText = Replace(SrchReplText, SrcTxt, RplTxt, 1, 1)
End If
End Function
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...