Помогите пожалуйста поправить макрос. Не пойму в чём может быть проблема. Ошибка периодическая, то есть возникает не каждый день, а хрен знает как. Вчера всё работало, сегодня не хочет, завтра будет работать опять.
Выдаёт ошибку Run-time error '13': Type mismatch
подсвечивает жёлтым строку
[vba]
Код
If rCell.Value = "Дата:" Then
[/vba]
Файл никак ужать до 100Kb не могу. если нужно выложу на файлообменник.
весь макрос полностью:
[vba]
Код
Sub SAVE() 'занесение Кп в таблицу и сохранение Кп и сметы Application.ScreenUpdating = False
Dim rCell As Range, rRange As Range, rTable As Long With CreateObject("Scripting.Dictionary") Set rRange = Sheets("КП (комплект)").UsedRange For Each rCell In rRange If rCell.Value = "Дата:" Then .Add Key:="дата", Item:=rCell.Offset(0, 1).Value End If
If rCell.Value = "Номер:" Then .Add Key:="Номер", Item:=rCell.Offset(0, 1).Value End If If rCell.Value = "Описание" Then .Add Key:="Наименование Оборудования", Item:=rCell.Offset(1, 0).Value End If If rCell.Value = "ИТОГО:" Then .Add Key:="Итого", Item:=rCell.Offset(0, 2).Value End If If rCell.Value = "Коммерческое предложение для" Then .Add Key:="Покупатель", Item:=rCell.Offset(0, 2).Value End If If rCell.Value = "Для:" Then .Add Key:="Пользователь", Item:=rCell.Offset(0, 1).Value End If If rCell.Value = "г. " Then .Add Key:="Город", Item:=rCell.Offset(0, 1).Value End If If rCell.Value = "конт:" Then .Add Key:="Контакт", Item:=rCell.Offset(0, 1).Value End If If rCell.Value = "тел:" Then .Add Key:="Телефон", Item:=rCell.Offset(0, 1).Value End If If rCell.Value = "Дата:" Then .Add Key:="Дата", Item:=rCell.Offset(0, 1).Value End If If rCell.Value = "E-mail:" Then .Add Key:="E-mail", Item:=rCell.Offset(0, 1).Value End If Next
For i = 1 To Sheets.Count 'проверка на уникальность номера КП If Sheets(i).Name = .Item("Номер") Then MsgBox "Такой номер КП уже сохраняли": Exit Sub End If Next rTable = Sheets("таблица").UsedRange.Rows.Count + 1 'Заполнение таблицы Sheets("таблица").Cells(rTable, 1).Formula = .Item("Дата") Sheets("таблица").Cells(rTable, 2).Formula = .Item("Номер")
Name = .Item("Номер") Sheets("таблица").Hyperlinks.Add Anchor:=Sheets("таблица").Cells(rTable, 2), Address:="", SubAddress:= _ "'" + Name + "'" + "!A1", TextToDisplay:=Name 'Создание гиперссылки на лист
'Перенос Кп на лист Sheets("КП (комплект)").Copy After:=Sheets(Sheets.Count) Sheets(Sheets.Count).UsedRange.Value = Sheets(Sheets.Count).UsedRange.Value Sheets(Sheets.Count).Name = .Item("Номер") 'удаление кнопки ActiveSheet.Shapes.Range(Array("Button 1")).Select Selection.Delete Selection.Cut
'защита листа от изменений ActiveSheet.Cells.Select Selection.Locked = True Selection.FormulaHidden = True ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
' Создание сметы отдельным файлом ActiveSheet.Copy 'копирование листа в новую книгу 'Сохранение в нужной папке с нужным именем. ActiveWorkbook.SaveAs "N:\MyDoc\11 КП\Сметы14\Смета на КП №" & Name & " " & Range("N19").Text & " " & Range("O19").Text & ".xls", FileFormat:=xlExcel8 ActiveWorkbook.Close
Помогите пожалуйста поправить макрос. Не пойму в чём может быть проблема. Ошибка периодическая, то есть возникает не каждый день, а хрен знает как. Вчера всё работало, сегодня не хочет, завтра будет работать опять.
Выдаёт ошибку Run-time error '13': Type mismatch
подсвечивает жёлтым строку
[vba]
Код
If rCell.Value = "Дата:" Then
[/vba]
Файл никак ужать до 100Kb не могу. если нужно выложу на файлообменник.
весь макрос полностью:
[vba]
Код
Sub SAVE() 'занесение Кп в таблицу и сохранение Кп и сметы Application.ScreenUpdating = False
Dim rCell As Range, rRange As Range, rTable As Long With CreateObject("Scripting.Dictionary") Set rRange = Sheets("КП (комплект)").UsedRange For Each rCell In rRange If rCell.Value = "Дата:" Then .Add Key:="дата", Item:=rCell.Offset(0, 1).Value End If
If rCell.Value = "Номер:" Then .Add Key:="Номер", Item:=rCell.Offset(0, 1).Value End If If rCell.Value = "Описание" Then .Add Key:="Наименование Оборудования", Item:=rCell.Offset(1, 0).Value End If If rCell.Value = "ИТОГО:" Then .Add Key:="Итого", Item:=rCell.Offset(0, 2).Value End If If rCell.Value = "Коммерческое предложение для" Then .Add Key:="Покупатель", Item:=rCell.Offset(0, 2).Value End If If rCell.Value = "Для:" Then .Add Key:="Пользователь", Item:=rCell.Offset(0, 1).Value End If If rCell.Value = "г. " Then .Add Key:="Город", Item:=rCell.Offset(0, 1).Value End If If rCell.Value = "конт:" Then .Add Key:="Контакт", Item:=rCell.Offset(0, 1).Value End If If rCell.Value = "тел:" Then .Add Key:="Телефон", Item:=rCell.Offset(0, 1).Value End If If rCell.Value = "Дата:" Then .Add Key:="Дата", Item:=rCell.Offset(0, 1).Value End If If rCell.Value = "E-mail:" Then .Add Key:="E-mail", Item:=rCell.Offset(0, 1).Value End If Next
For i = 1 To Sheets.Count 'проверка на уникальность номера КП If Sheets(i).Name = .Item("Номер") Then MsgBox "Такой номер КП уже сохраняли": Exit Sub End If Next rTable = Sheets("таблица").UsedRange.Rows.Count + 1 'Заполнение таблицы Sheets("таблица").Cells(rTable, 1).Formula = .Item("Дата") Sheets("таблица").Cells(rTable, 2).Formula = .Item("Номер")
Name = .Item("Номер") Sheets("таблица").Hyperlinks.Add Anchor:=Sheets("таблица").Cells(rTable, 2), Address:="", SubAddress:= _ "'" + Name + "'" + "!A1", TextToDisplay:=Name 'Создание гиперссылки на лист
'Перенос Кп на лист Sheets("КП (комплект)").Copy After:=Sheets(Sheets.Count) Sheets(Sheets.Count).UsedRange.Value = Sheets(Sheets.Count).UsedRange.Value Sheets(Sheets.Count).Name = .Item("Номер") 'удаление кнопки ActiveSheet.Shapes.Range(Array("Button 1")).Select Selection.Delete Selection.Cut
'защита листа от изменений ActiveSheet.Cells.Select Selection.Locked = True Selection.FormulaHidden = True ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
' Создание сметы отдельным файлом ActiveSheet.Copy 'копирование листа в новую книгу 'Сохранение в нужной папке с нужным именем. ActiveWorkbook.SaveAs "N:\MyDoc\11 КП\Сметы14\Смета на КП №" & Name & " " & Range("N19").Text & " " & Range("O19").Text & ".xls", FileFormat:=xlExcel8 ActiveWorkbook.Close
Файл качать не буду, но возможны такие варианты: 1. missing в references VBA 2. ошибка в ячейке.
Вообще эту кучу [vba]
Код
If rCell.Value = ... Then
[/vba] лучше заменить на одно извлечение значения ячейки в переменную и её проверка в select case - так будет быстрее. Ещё быстрее делать на массиве. И зачем там два раза [vba]
Код
If rCell.Value = "Дата:" Then
[/vba] ?
Файл качать не буду, но возможны такие варианты: 1. missing в references VBA 2. ошибка в ячейке.
Вообще эту кучу [vba]
Код
If rCell.Value = ... Then
[/vba] лучше заменить на одно извлечение значения ячейки в переменную и её проверка в select case - так будет быстрее. Ещё быстрее делать на массиве. И зачем там два раза [vba]
я не специалист в макросах, то что сделано, - сделано с помощью этого форума, где то люди подсказали, где то сам дошёл (выпилил кусок и вставил себе), где то макрорекордером писано. Ваши варианты мне не дают информации о том как исправить ситуацию. Повтор удалил, но ничего не изменилось. Что может меняться в свойствах файла/листа /ячейки - что приводит к ошибке? на что обратить внимание? я же говорю что проблема может сама исчезнуть завтра например. или сегодня на xx открытие файла. и так же неожиданно снова проявиться. сегодня с утра всё работало, к обеду перестало.
Для примера, если я напишу вам "для исследования HeLa нужно использовать 40x-60х PH, а лучше DIC" - вы ведь не поймёте о чём речь. Это я к тому что чайник не поймёт специалиста если он своей терминологией кидаться будет, вместо того чтобы объяснить.
Hugo, Спасибо за ответ, но это ничего не решает.
я не специалист в макросах, то что сделано, - сделано с помощью этого форума, где то люди подсказали, где то сам дошёл (выпилил кусок и вставил себе), где то макрорекордером писано. Ваши варианты мне не дают информации о том как исправить ситуацию. Повтор удалил, но ничего не изменилось. Что может меняться в свойствах файла/листа /ячейки - что приводит к ошибке? на что обратить внимание? я же говорю что проблема может сама исчезнуть завтра например. или сегодня на xx открытие файла. и так же неожиданно снова проявиться. сегодня с утра всё работало, к обеду перестало.
Для примера, если я напишу вам "для исследования HeLa нужно использовать 40x-60х PH, а лучше DIC" - вы ведь не поймёте о чём речь. Это я к тому что чайник не поймёт специалиста если он своей терминологией кидаться будет, вместо того чтобы объяснить.ilikeread
ilikeread, если формула в ячейке (rCell) возвращает ошибку, то If rCell.Value = "Дата:" Then приводит к ошибке Тype mismatch Или поправьте формулы (ЕСЛИОШИБКА, например), чтобы не было #Н/Д, #Знач и пр. или добавьте в код проверку If Not IsError(rCell) Then примерно так: [vba]
Код
For Each rCell In rRange If Not IsError(rCell) Then If rCell.Value = "Дата:" Then .Add Key:="äàòà", Item:=rCell.Offset(0, 1).Value End If ... End If Next
[/vba] Лучше бы, конечно, переписать весь код.
ilikeread, если формула в ячейке (rCell) возвращает ошибку, то If rCell.Value = "Дата:" Then приводит к ошибке Тype mismatch Или поправьте формулы (ЕСЛИОШИБКА, например), чтобы не было #Н/Д, #Знач и пр. или добавьте в код проверку If Not IsError(rCell) Then примерно так: [vba]
Код
For Each rCell In rRange If Not IsError(rCell) Then If rCell.Value = "Дата:" Then .Add Key:="äàòà", Item:=rCell.Offset(0, 1).Value End If ... End If Next
[/vba] Лучше бы, конечно, переписать весь код.nilem
nilem, Спасибо помогло " If Not IsError(rCell) Then"
переписать конечно наверно хорошо, НО я ж не специалист , тут строки вымученные :), я почти каждую понимаю что делает. для переписывания нужно учить мат часть, , а у меня и без этого головняков хватает. формулами и макросами просто пытаюсь рабпроцесс оптимизировать.
Ещё раз спасибо.
nilem, Спасибо помогло " If Not IsError(rCell) Then"
переписать конечно наверно хорошо, НО я ж не специалист , тут строки вымученные :), я почти каждую понимаю что делает. для переписывания нужно учить мат часть, , а у меня и без этого головняков хватает. формулами и макросами просто пытаюсь рабпроцесс оптимизировать.
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
