VBScript: Поиск и автозамена данных в .xls

Option Compare Text

Sub Example()
Dim objFS As FileSystemObject, objFile As TextStream, strPath As String
Dim arrTemp, arrIDs() As String, arrNames() As String
Dim strTemp, lngTemp As Long, i As Long, j As Long
Dim objNonEmptyCells As Range, objItem As Range

strPath = "C:\Temp\id.txt"
Set objFS = New FileSystemObject
If objFS.FileExists(strPath) Then
    If objFS.GetFile(strPath).Size > 0 Then
        Set objFile = objFS.OpenTextFile(strPath, ForReading)
        strTemp = objFile.ReadAll
        objFile.Close
        Set objFile = Nothing
        arrTemp = Split(strTemp, vbNewLine)
        lngTemp = UBound(arrTemp)
        j = -1
        For i = 0 To lngTemp
            If Len(arrTemp(i)) > 0 Then
                j = j + 1
                ReDim Preserve arrIDs(j): ReDim Preserve arrNames(j)
                strTemp = Split(arrTemp(i), vbTab)
                arrIDs(j) = strTemp(1)
                arrNames(j) = strTemp(0)
            End If
        Next
        Erase arrTemp
        On Error Resume Next
        Set objNonEmptyCells = Worksheets(1).Cells.SpecialCells(xlCellTypeConstants)
        If Err.Number = 0 Then
            On Error GoTo 0
            For Each objItem In objNonEmptyCells
                strTemp = objItem.Value
                For i = 0 To UBound(arrIDs)
                    If InStr(strTemp, arrIDs(i)) > 0 Then
                        objItem.Value = Replace(strTemp, arrIDs(i), arrNames(i))
                        Exit For
                    End If
                Next
            Next
            Set objNonEmptyCells = Nothing
            Erase arrIDs: Erase arrNames
            MsgBox "Готово.", vbInformation
        Else
            Err.Clear
            MsgBox "Рабочий лист не содержит строковых констант.", vbCritical
        End If
    Else
        MsgBox "Файл " & UCase(strPath) & " пуст.", vbCritical
    End If
Else
    MsgBox "Путь " & UCase(strPath) & " не найден.", vbCritical
End If
Set objFS = Nothing
End Sub

Dim objFS, objFile, strFile
Dim objExcel, objWB, strBook
Dim objNonEmptyCells, objItem
Dim arrTemp, arrIDs(), arrNames()
Dim strTemp, lngTemp, i, j

strFile = "C:\Temp\id.txt"
strBook = "C:\Temp\book.xls"
Set objFS = CreateObject("Scripting.FileSystemObject")
If objFS.FileExists(strFile) Then
    If objFS.GetFile(strFile).Size > 0 Then
        Set objFile = objFS.OpenTextFile(strFile, 1)
        strTemp = objFile.ReadAll
        objFile.Close
        Set objFile = Nothing
        arrTemp = Split(strTemp, vbNewLine)
        lngTemp = UBound(arrTemp)
        j = -1
        For i = 0 To lngTemp
            If Len(arrTemp(i)) > 0 Then
                j = j + 1
                ReDim Preserve arrIDs(j): ReDim Preserve arrNames(j)
                strTemp = Split(arrTemp(i), vbTab)
                arrIDs(j) = strTemp(1)
                arrNames(j) = strTemp(0)
            End If
        Next
        Erase arrTemp
        If objFS.FileExists(strBook) Then
            Set objExcel = CreateObject("Excel.Application")
            Set objWB = objExcel.Workbooks.Open(strBook)
            On Error Resume Next
            Set objNonEmptyCells = objWB.Worksheets(1).Cells.SpecialCells(2)
            If Err.Number = 0 Then
                On Error GoTo 0
                For Each objItem In objNonEmptyCells
                    strTemp = objItem.Value
                    For i = 0 To UBound(arrIDs)
                        If InStr(strTemp, arrIDs(i)) > 0 Then
                            objItem.Value = Replace(strTemp, arrIDs(i), arrNames(i))
                            Exit For
                        End If
                    Next
                Next
                Set objNonEmptyCells = Nothing
                Erase arrIDs: Erase arrNames
                objWB.Save
                WScript.Echo "Готово."
            Else
                Err.Clear
                objWB.Saved = True
                WScript.Echo "Рабочий лист не содержит строковых констант."
            End If
            objWB.Close
            Set objWB = Nothing
            objExcel.Quit
            Set objExcel = Nothing
        Else
            WScript.Echo "Путь " & UCase(strBook) & " не найден."
        End If
    Else
        WScript.Echo "Файл " & UCase(strFile) & " пуст."
    End If
Else
    WScript.Echo "Путь " & UCase(strFile) & " не найден."
End If
Set objFS = Nothing
WScript.Quit 0

Dim objFS, objFile, strFile
Dim objExcel, objWB, strBook
Dim objNonEmptyCells, objItem
Dim arrTemp, arrIDs(), arrNames()
Dim strTemp, lngTemp, i, j

Set objExcel = CreateObject("Excel.Application")
With objExcel.FileDialog(1)
    .AllowMultiSelect = False
    .Filters.Clear
    .Filters.Add "Простой текст", "*.txt"
    .Show
    If .SelectedItems.Count = 1 Then
        strFile = .SelectedItems(1)
    End If
End With
If Len(strFile) > 0 Then
    Set objFS = CreateObject("Scripting.FileSystemObject")
    If objFS.GetFile(strFile).Size > 0 Then
        Set objFile = objFS.OpenTextFile(strFile, 1)
        strTemp = objFile.ReadAll
        objFile.Close
        Set objFile = Nothing
        arrTemp = Split(strTemp, vbNewLine)
        lngTemp = UBound(arrTemp)
        j = -1
        For i = 0 To lngTemp
            If Len(arrTemp(i)) > 0 Then
                j = j + 1
                ReDim Preserve arrIDs(j): ReDim Preserve arrNames(j)
                strTemp = Split(arrTemp(i), vbTab)
                arrIDs(j) = strTemp(1)
                arrNames(j) = strTemp(0)
            End If
        Next
        Erase arrTemp
        With objExcel.FileDialog(1)
            .AllowMultiSelect = False
            .Filters.Clear
            .Filters.Add "Рабочая книга Excel", "*.xls"
            .Show
            If .SelectedItems.Count = 1 Then
                strBook = .SelectedItems(1)
            End If
        End With
        objExcel.Visible = False
        If Len(strBook) > 0 Then
            Set objWB = objExcel.Workbooks.Open(strBook)
            On Error Resume Next
            Set objNonEmptyCells = objWB.Worksheets(1).Cells.SpecialCells(2)
            If Err.Number = 0 Then
                On Error GoTo 0
                For Each objItem In objNonEmptyCells
                    strTemp = objItem.Value
                    For i = 0 To UBound(arrIDs)
                        If InStr(strTemp, arrIDs(i)) > 0 Then
                            objItem.Value = Replace(strTemp, arrIDs(i), arrNames(i))
                            Exit For
                        End If
                    Next
                Next
                Set objNonEmptyCells = Nothing
                Erase arrIDs: Erase arrNames
                objWB.Save
                WScript.Echo "Готово."
            Else
                Err.Clear
                objWB.Saved = True
                WScript.Echo "Рабочий лист не содержит строковых констант."
            End If
            objWB.Close
            Set objWB = Nothing
            objExcel.Quit
        Else
            WScript.Echo "Файл с рабочей книгой не выбран."
        End If
    Else
        WScript.Echo "Файл " & UCase(strFile) & " пуст."
    End If
    Set objFS = Nothing
Else
    WScript.Echo "Файл с таблицей сопоставления не выбран."
End If
Set objExcel = Nothing
WScript.Quit 0