Как победить плавающую ошибку, возникающую на "словаре" в VBA. Run-time error '13': Type mismatch

@zamboga · Регистрация: 25.11.2016

Author24 — интернет-сервис помощи студентам

В продолжении Расширение стандартного поиска. Как искать списки слов в Excel?

Описание задачи.
Найти все вхождения любого слова из приложенного списка "Исходные данные", файл ИД.txt. Найти надо в любой ячейке в любом листе книги.
На выходе отобразить список ИД и информацией, где встретились совпадения.

Глобально на входе будет список из 10-10000 строк, и искать он должен в таблицах из 1-50 листов и 100-100 000 строк.
В качестве примера данных гораздо меньше.

Изначально скрипт не мой, но я основательно разобрал его по косточкам, понял как он работает, снабдил его комментариями и дописал его под себя. Особенно запутало меня наличие "словаря" при работе данного скрипта.

Visual Basic

Sub pr()
    Dim sh As Worksheet, t$
    Dim lLastRow As Long, lLastCol As Long, r As Long, i As Long, j As Long
        
   
    Windows("Скрипт поиска.xlsm").Activate
     
    'альтернативный способ задать массив без открытия файла. не подходит для фраз, состоящих более чем из одного слова.
    'a = Split(CreateObject("Scripting.FileSystemObject").Getfile(ActiveWorkbook.Path & "\ИД.txt").OpenasTextStream(1).ReadAll, vbNewLine)
     
    'открываем файл с Исходными Данными
    PathFileTxt = ActiveWorkbook.Path & "\ИД.txt"
    Workbooks.OpenText Filename:=PathFileTxt, Origin:=1251
    Columns("A:A").Select
     
    'разбиваем по столбцам чтобы найти слова, а не фразы
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
     
     
    'удаляем пустые строки
    LastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count    'определяем размеры таблицы
    Application.ScreenUpdating = False
    For r = LastRow To 1 Step -1           'проходим от последней строки до первой
        If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete   'если в строке пусто - удаляем ее
    Next r
       
     
    'определяем последнюю ячейку с данными
    With ActiveSheet.UsedRange: End With
    lLastRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
    lLastCol = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
     
    'задаем массив исходных данных
    'a = [a1].CurrentRegion.Value       'ограничивает диапазон первой пустой строкой/столбцом, не подходит
    a = Range(Cells(1, 1), Cells(lLastRow, lLastCol)).Value
    ActiveWorkbook.Close False
     
    'создаем словарь с исходными данными для поиска
    With CreateObject("scripting.dictionary")
        For Each el In a
             .Item(el) = ""
        Next
        MsgBox "Список ключей для поиска:" & vbLf & vbLf & Join(.Keys, vbLf)
    'ищем в словаре совпадения на наших листах
        For Each sh In Sheets
            'определяем последнюю ячейку с данными
            With sh.UsedRange: End With
            lLastRow = sh.UsedRange.Row + sh.UsedRange.Rows.Count - 1
            lLastCol = sh.UsedRange.Column + sh.UsedRange.Columns.Count - 1
            'задаем массив
            a = sh.Range(sh.Cells(1, 1), sh.Cells(lLastRow, lLastCol)).Value
            'a = [a1].CurrentRegion.Value       'ограничивает диапазон первой пустой строкой/столбцом
            'забиваем словарь адресами ячеек, в которых есть совпадения с ИД
            For i = 1 To UBound(a)
                For j = 1 To UBound(a, 2)
                    t = a(i, j)
 
'111111 эта строка норм работает
'                   If .exists(t) Then .Item(t) = .Item(t) & IIf(.Item(t) = "", "", ";") & sh.Name & "(" & i & "," & j & ")"
 
'222222 эта строка НЕ работает, хотя она просто длиннее прошлой, и MsgBox ее отрабатывает так, как и надо в итоге.
'                  MsgBox "=ГИПЕРССЫЛКА(""[" & Application.ActiveWorkbook.FullName & "]" & sh.Name & "!""&АДРЕС(" & i & ";" & j & ");""" & sh.Name & "!""&АДРЕС(" & i & ";" & j & "))"
                  If .exists(t) Then .Item(t) = .Item(t) & IIf(.Item(t) = "", "", ";") & "=ГИПЕРССЫЛКА(""[" & Application.ActiveWorkbook.FullName & "]" & sh.Name & "!""&АДРЕС(" & i & ";" & j & ");""" & sh.Name & "!""&АДРЕС(" & i & ";" & j & "))"
                 
                Next
            Next
             
        Next
         
        'создаем новую книгу
        Workbooks.Add
         
        'вытаскиваем из словаря ключи (keys) и их значения (items)
        ActiveSheet.[a1].Resize(.Count, 2) = Application.Transpose(Array(.Keys, .Items))
         
        'разбиваем в колонке B:B текст по столбцам, разделитель -- точка с запятой.
        Columns("B:B").Select
        Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
        Columns("B:XFD").EntireColumn.AutoFit
        Range("A1").Activate
        Application.ScreenUpdating = True
        MsgBox "Done!"
        'ActiveWorkbook.Close False
    End With
 End Sub

Вопросы.

1. Валится ошибка Run-time error '13': Type mismatch в самом конце работы скрипта, при построении итогового массива и отображением его на экране ( 'вытаскиваем из словаря ключи (keys) и их значения (items)). Опытным путем установлено, что проблема возникает из-за строки, обозначенной '222222 в скрипте. Как победить? При этом точно такая же строка '111111, которая короче по длине, отрабатывает нормально.

2. Валится ошибка Run-time error '13': Type mismatch, (надо активировать строку '111111 и закоментить '222222), если добавить в таблицу "искать тут.xlsm" пустые строки и/или столбцы, как на скриншоте. -- а это очень актуальная проблема, т.к. файлы с данными для поиска имеют совершенно разную структуру и могут содержать любое число пустых строк и столбцов.

3. В изначальном скрипте кроме "Dim sh As Worksheet, t$" объявлений переменных больше не было, остальные, про тип которых знаю, я добавлял сам. В массивах и словарях я совсем не силен. Судя по гуглению яндекса, ошибка 13 может быть из-за этого. Подскажите, каким типом надо правильно объявить все используемые в скрипте переменные?

4. Входные фразы могут состоять из любого числа слов. При формировании одномерного массива туда попадает пустая строка (см скрин ). Как этого избежать?

5. Как посмотреть значения .Key и значения .Item в созданном словаре во время отладки? Через MsgBox очень не удобно, а никакой другой способ я так и не нагуглил.

@zamboga · 01.12.2016, 14:07 **[ТС]**

На другом форуме совместными усилиями ошибку победили.

Рабочий код:

Visual Basic

Option Explicit
Sub pr3()
    Dim sh As Worksheet, t$
    Dim lLastRow As Long, lLastCol As Long, LastRow As Long, r As Long, i As Long, j As Long
    Dim PathFileTxt As String
    Dim dic As Object
    Dim el As Variant
    Dim a
    
    Windows("искать тут.xlsm").Activate
      
    'альтернативный способ задать массив без открытия файла. не подходит для фраз, состоящих более чем из одного слова.
    'a = Split(CreateObject("Scripting.FileSystemObject").Getfile(ActiveWorkbook.Path & "\ИД.txt").OpenasTextStream(1).ReadAll, vbNewLine)
      
    'открываем файл с Исходными Данными
    PathFileTxt = ActiveWorkbook.Path & "\ИД.txt"
    Workbooks.OpenText Filename:=PathFileTxt, Origin:=1251
    Columns("A:A").Select
      
    'разбиваем по столбцам чтобы найти слова, а не фразы
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
      
      
    'удаляем пустые строки
    LastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count    'определяем размеры таблицы
    Application.ScreenUpdating = False
    For r = LastRow To 1 Step -1           'проходим от последней строки до первой
        If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete   'если в строке пусто - удаляем ее
    Next r
        
      
    'определяем последнюю ячейку с данными
    With ActiveSheet.UsedRange: End With
    lLastRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
    lLastCol = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
      
    'задаем массив исходных данных
    'a = [a1].CurrentRegion.Value       'ограничивает диапазон первой пустой строкой/столбцом, не подходит
    a = Range(Cells(1, 1), Cells(lLastRow, lLastCol)).Value
    ActiveWorkbook.Close False
      
    'создаем словарь с исходными данными для поиска
    Set dic = CreateObject("scripting.dictionary")
    dic.comparemode = 1
    With dic
        For Each el In a
            If el <> "" Then
             .Item(el) = ""
            End If
        Next
'        MsgBox "Список ключей для поиска:" & vbLf & vbLf & Join(.keys, vbLf)
    'ищем в словаре совпадения на наших листах
        For Each sh In Sheets
            'определяем последнюю ячейку с данными
            With sh.UsedRange: End With
            lLastRow = sh.UsedRange.Row + sh.UsedRange.Rows.Count - 1
            lLastCol = sh.UsedRange.Column + sh.UsedRange.Columns.Count - 1
            'задаем массив
            a = sh.Range(sh.Cells(1, 1), sh.Cells(lLastRow, lLastCol)).Value
            'a = [a1].CurrentRegion.Value       'ограничивает диапазон первой пустой строкой/столбцом
            'забиваем словарь адресами ячеек, в которых есть совпадения с ИД
            For i = 1 To UBound(a)
                For j = 1 To UBound(a, 2)
                    t = a(i, j)
'                    MsgBox "=ГИПЕРССЫЛКА(""[" & Application.ActiveWorkbook.FullName & "]" & sh.Name & "!""&АДРЕС(" & i & ";" & j & ");""" & sh.Name & "!""&АДРЕС(" & i & ";" & j & "))"
                    If .exists(t) Then .Item(t) = .Item(t) & IIf(.Item(t) = "", "", "|") & "=ГИПЕРССЫЛКА(""[" & Application.ActiveWorkbook.FullName & "]" & sh.Name & "!""&АДРЕС(" & i & ";" & j & ");""" & sh.Name & "!""&АДРЕС(" & i & ";" & j & ";4))"
                Next
            Next
              
        Next
          
'вытаскиваем из словаря ключи (keys) и их значения (items)
        Dim aK, aI, aSP, s As String, ss As String
        Dim lMaxC As Long, lc As Long
        aK = .keys
        aI = .items
        ReDim a(1 To .Count, 1 To 100)
        For i = 1 To .Count
            a(i, 1) = aK(i - 1)
            s = .Item((aK(i - 1)))
            If s <> "" Then
                aSP = Split(s, "|")
                lc = UBound(aSP) + 1
                If lMaxC < lc Then
                    lMaxC = lc
                End If
                For lc = LBound(aSP) To UBound(aSP)
                    ss = aSP(lc)
                    a(i, lc + 2) = ss
                Next
            End If
        Next
 
        'создаем новую книгу
        Workbooks.Add
 
        'вставляем данные на лист
        ActiveSheet.[a1].Resize(.Count, lMaxC + 1).FormulaLocal = a
         
        Columns("B:XFD").EntireColumn.AutoFit
        Range("A1").Activate
        Application.ScreenUpdating = True
'        MsgBox "Done!"
'        ActiveWorkbook.Close False
    End With
 End Sub

	01.12.2016, 14:07