Sub KolDub()
c0_ = 5
nc_ = Cells(1).SpecialCells(xlLastCell).Column - c0_ + 1 If nc_ < 1ThenExitSub
r0_ = 1
nr_ = Cells(1).SpecialCells(xlLastCell).Row - r0_ + 1 If nr_ < 1ThenExitSub
ar = Cells(r0_, c0_).Resize(nr_, nc_) Dim ColSlov1 AsNew Collection Dim ColSlov2 AsNew Collection OnErrorResumeNext With ColSlov1 For i = 1To nr_ For j = 1To nc_ IfNotIsEmpty(ar(i, j)) Then
.Item CStr(ar(i, j)) If Err = 0Then
z_ = z_ + 1
ColSlov2.Item CStr(ar(i, j)) If Err > 0Then
ColSlov2.Add Item:=ar(i, j), Key:=CStr(ar(i, j))
Err.Clear EndIf Else
Err.Clear
.Add Item:=ar(i, j), Key:=CStr(ar(i, j)) EndIf EndIf Next j Next i EndWith
Cells(1, 2) = z_ + ColSlov2.Count EndSub
2,22 сек.
Sub KolDub()
t = Timer
c0_ = 5
nc_ = Cells(1).SpecialCells(xlLastCell).Column - c0_ + 1 If nc_ < 1ThenExitSub
r0_ = 1
nr_ = Cells(1).SpecialCells(xlLastCell).Row - r0_ + 1 If nr_ < 1ThenExitSub
ar = Cells(r0_, c0_).Resize(nr_, nc_) Dim ColSlov1 AsNew Collection Dim ColSlov2 AsNew Collection OnErrorResumeNext With ColSlov1 For i = 1To nr_ For j = 1To nc_ IfNotIsEmpty(ar(i, j)) Then
c = CStr(ar(i, j))
.Item c If Err = 0Then
z_ = z_ + 1
ColSlov2.Item c If Err > 0Then
ColSlov2.Add Item:=1, Key:=c
Err.Clear EndIf Else
Err.Clear
.Add Item:=1, Key:=c EndIf EndIf Next j Next i EndWith
Cells(1, 2) = z_ + ColSlov2.Count Debug.Print"end " & Format(Timer - t, "0.00") EndSub
И перебор не массива, а работа с листом, чуть медленнее, но не существенно
Sub KolDub2()
t = Timer
c0_ = 5
nc_ = Cells(1).SpecialCells(xlLastCell).Column - c0_ + 1 If nc_ < 1ThenExitSub
r0_ = 1
nr_ = Cells(1).SpecialCells(xlLastCell).Row - r0_ + 1 If nr_ < 1ThenExitSub Dim ColSlov1 AsNew Collection Dim ColSlov2 AsNew Collection OnErrorResumeNext With ColSlov1 For Each cell In Cells(r0_, c0_).Resize(nr_, nc_)
c = CStr(cell) If c <> ""Then
.Item c If Err = 0Then
z_ = z_ + 1
ColSlov2.Item c If Err > 0Then
ColSlov2.Add Item:=1, Key:=c
Err.Clear EndIf Else
Err.Clear
.Add Item:=1, Key:=c EndIf EndIf Next EndWith
Sub KolDub()
c0_ = 5
nc_ = Cells(1).SpecialCells(xlLastCell).Column - c0_ + 1 If nc_ < 1ThenExitSub
r0_ = 1
nr_ = Cells(1).SpecialCells(xlLastCell).Row - r0_ + 1 If nr_ < 1ThenExitSub
ar = Cells(r0_, c0_).Resize(nr_, nc_) Dim ColSlov1 AsNew Collection Dim ColSlov2 AsNew Collection OnErrorResumeNext With ColSlov1 For i = 1To nr_ For j = 1To nc_ IfNotIsEmpty(ar(i, j)) Then
.Item CStr(ar(i, j)) If Err = 0Then
z_ = z_ + 1
ColSlov2.Item CStr(ar(i, j)) If Err > 0Then
ColSlov2.Add Item:=ar(i, j), Key:=CStr(ar(i, j))
Err.Clear EndIf Else
Err.Clear
.Add Item:=ar(i, j), Key:=CStr(ar(i, j)) EndIf EndIf Next j Next i EndWith
Cells(1, 2) = z_ + ColSlov2.Count EndSub
2,22 сек.
Sub KolDub()
t = Timer
c0_ = 5
nc_ = Cells(1).SpecialCells(xlLastCell).Column - c0_ + 1 If nc_ < 1ThenExitSub
r0_ = 1
nr_ = Cells(1).SpecialCells(xlLastCell).Row - r0_ + 1 If nr_ < 1ThenExitSub
ar = Cells(r0_, c0_).Resize(nr_, nc_) Dim ColSlov1 AsNew Collection Dim ColSlov2 AsNew Collection OnErrorResumeNext With ColSlov1 For i = 1To nr_ For j = 1To nc_ IfNotIsEmpty(ar(i, j)) Then
c = CStr(ar(i, j))
.Item c If Err = 0Then
z_ = z_ + 1
ColSlov2.Item c If Err > 0Then
ColSlov2.Add Item:=1, Key:=c
Err.Clear EndIf Else
Err.Clear
.Add Item:=1, Key:=c EndIf EndIf Next j Next i EndWith
Cells(1, 2) = z_ + ColSlov2.Count Debug.Print"end " & Format(Timer - t, "0.00") EndSub
И перебор не массива, а работа с листом, чуть медленнее, но не существенно
Sub KolDub2()
t = Timer
c0_ = 5
nc_ = Cells(1).SpecialCells(xlLastCell).Column - c0_ + 1 If nc_ < 1ThenExitSub
r0_ = 1
nr_ = Cells(1).SpecialCells(xlLastCell).Row - r0_ + 1 If nr_ < 1ThenExitSub Dim ColSlov1 AsNew Collection Dim ColSlov2 AsNew Collection OnErrorResumeNext With ColSlov1 For Each cell In Cells(r0_, c0_).Resize(nr_, nc_)
c = CStr(cell) If c <> ""Then
.Item c If Err = 0Then
z_ = z_ + 1
ColSlov2.Item c If Err > 0Then
ColSlov2.Add Item:=1, Key:=c
Err.Clear EndIf Else
Err.Clear
.Add Item:=1, Key:=c EndIf EndIf Next EndWith
bmv98rus, RAN, _Boroda_, Спасибо Вам огромное за такое активное решение проблемы))) Каждый из предложенных способов буду пробовать)) Еще раз огромное человеческое СПАСИБО!
bmv98rus, RAN, _Boroda_, Спасибо Вам огромное за такое активное решение проблемы))) Каждый из предложенных способов буду пробовать)) Еще раз огромное человеческое СПАСИБО!rtv206
_Boroda_, bmv98rus, подскажите, пожалуйста, вставляю Ваши макросы в форму и выдает ошибку: "Compile error/ Method or data member not found. Что делаю не так?
_Boroda_, bmv98rus, подскажите, пожалуйста, вставляю Ваши макросы в форму и выдает ошибку: "Compile error/ Method or data member not found. Что делаю не так?rtv206
Добрый день! Прошу помощи- скачал файл с сообщения 36, когда открываю выскакивает ошибка: Ошибка в части содержимого в книге 0919900_2.xlsm. Выполнить попытку восстановления?...... Что это может быть?
Добрый день! Прошу помощи- скачал файл с сообщения 36, когда открываю выскакивает ошибка: Ошибка в части содержимого в книге 0919900_2.xlsm. Выполнить попытку восстановления?...... Что это может быть?rtv206
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
