Sub KolDub() c0_ = 5 nc_ = Cells(1).SpecialCells(xlLastCell).Column - c0_ + 1 If nc_ < 1 Then Exit Sub r0_ = 1 nr_ = Cells(1).SpecialCells(xlLastCell).Row - r0_ + 1 If nr_ < 1 Then Exit Sub ar = Cells(r0_, c0_).Resize(nr_, nc_) Dim ColSlov1 As New Collection Dim ColSlov2 As New Collection On Error Resume Next With ColSlov1 For i = 1 To nr_ For j = 1 To nc_ If Not IsEmpty(ar(i, j)) Then .Item CStr(ar(i, j)) If Err = 0 Then z_ = z_ + 1 ColSlov2.Item CStr(ar(i, j)) If Err > 0 Then ColSlov2.Add Item:=ar(i, j), Key:=CStr(ar(i, j)) Err.Clear End If Else Err.Clear .Add Item:=ar(i, j), Key:=CStr(ar(i, j)) End If End If Next j Next i End With Cells(1, 2) = z_ + ColSlov2.Count End Sub
[/vba]
2,22 сек.
[vba]
Код
Sub KolDub() t = Timer c0_ = 5 nc_ = Cells(1).SpecialCells(xlLastCell).Column - c0_ + 1 If nc_ < 1 Then Exit Sub r0_ = 1 nr_ = Cells(1).SpecialCells(xlLastCell).Row - r0_ + 1 If nr_ < 1 Then Exit Sub ar = Cells(r0_, c0_).Resize(nr_, nc_) Dim ColSlov1 As New Collection Dim ColSlov2 As New Collection On Error Resume Next With ColSlov1 For i = 1 To nr_ For j = 1 To nc_ If Not IsEmpty(ar(i, j)) Then c = CStr(ar(i, j)) .Item c If Err = 0 Then z_ = z_ + 1 ColSlov2.Item c If Err > 0 Then ColSlov2.Add Item:=1, Key:=c Err.Clear End If Else Err.Clear .Add Item:=1, Key:=c End If End If Next j Next i End With Cells(1, 2) = z_ + ColSlov2.Count Debug.Print "end " & Format(Timer - t, "0.00") End Sub
[/vba]
И перебор не массива, а работа с листом, чуть медленнее, но не существенно
[vba]
Код
Sub KolDub2() t = Timer c0_ = 5 nc_ = Cells(1).SpecialCells(xlLastCell).Column - c0_ + 1 If nc_ < 1 Then Exit Sub r0_ = 1 nr_ = Cells(1).SpecialCells(xlLastCell).Row - r0_ + 1 If nr_ < 1 Then Exit Sub Dim ColSlov1 As New Collection Dim ColSlov2 As New Collection On Error Resume Next With ColSlov1 For Each cell In Cells(r0_, c0_).Resize(nr_, nc_) c = CStr(cell) If c <> "" Then .Item c If Err = 0 Then z_ = z_ + 1 ColSlov2.Item c If Err > 0 Then ColSlov2.Add Item:=1, Key:=c Err.Clear End If Else Err.Clear .Add Item:=1, Key:=c End If End If Next End With
Cells(1, 2) = z_ + ColSlov2.Count Debug.Print "end " & Format(Timer - t, "0.00") End Sub
[/vba]
Нужно похоже на коллекции переходить
[vba]
Код
Sub KolDub() c0_ = 5 nc_ = Cells(1).SpecialCells(xlLastCell).Column - c0_ + 1 If nc_ < 1 Then Exit Sub r0_ = 1 nr_ = Cells(1).SpecialCells(xlLastCell).Row - r0_ + 1 If nr_ < 1 Then Exit Sub ar = Cells(r0_, c0_).Resize(nr_, nc_) Dim ColSlov1 As New Collection Dim ColSlov2 As New Collection On Error Resume Next With ColSlov1 For i = 1 To nr_ For j = 1 To nc_ If Not IsEmpty(ar(i, j)) Then .Item CStr(ar(i, j)) If Err = 0 Then z_ = z_ + 1 ColSlov2.Item CStr(ar(i, j)) If Err > 0 Then ColSlov2.Add Item:=ar(i, j), Key:=CStr(ar(i, j)) Err.Clear End If Else Err.Clear .Add Item:=ar(i, j), Key:=CStr(ar(i, j)) End If End If Next j Next i End With Cells(1, 2) = z_ + ColSlov2.Count End Sub
[/vba]
2,22 сек.
[vba]
Код
Sub KolDub() t = Timer c0_ = 5 nc_ = Cells(1).SpecialCells(xlLastCell).Column - c0_ + 1 If nc_ < 1 Then Exit Sub r0_ = 1 nr_ = Cells(1).SpecialCells(xlLastCell).Row - r0_ + 1 If nr_ < 1 Then Exit Sub ar = Cells(r0_, c0_).Resize(nr_, nc_) Dim ColSlov1 As New Collection Dim ColSlov2 As New Collection On Error Resume Next With ColSlov1 For i = 1 To nr_ For j = 1 To nc_ If Not IsEmpty(ar(i, j)) Then c = CStr(ar(i, j)) .Item c If Err = 0 Then z_ = z_ + 1 ColSlov2.Item c If Err > 0 Then ColSlov2.Add Item:=1, Key:=c Err.Clear End If Else Err.Clear .Add Item:=1, Key:=c End If End If Next j Next i End With Cells(1, 2) = z_ + ColSlov2.Count Debug.Print "end " & Format(Timer - t, "0.00") End Sub
[/vba]
И перебор не массива, а работа с листом, чуть медленнее, но не существенно
[vba]
Код
Sub KolDub2() t = Timer c0_ = 5 nc_ = Cells(1).SpecialCells(xlLastCell).Column - c0_ + 1 If nc_ < 1 Then Exit Sub r0_ = 1 nr_ = Cells(1).SpecialCells(xlLastCell).Row - r0_ + 1 If nr_ < 1 Then Exit Sub Dim ColSlov1 As New Collection Dim ColSlov2 As New Collection On Error Resume Next With ColSlov1 For Each cell In Cells(r0_, c0_).Resize(nr_, nc_) c = CStr(cell) If c <> "" Then .Item c If Err = 0 Then z_ = z_ + 1 ColSlov2.Item c If Err > 0 Then ColSlov2.Add Item:=1, Key:=c Err.Clear End If Else Err.Clear .Add Item:=1, Key:=c End If End If Next End With
Cells(1, 2) = z_ + ColSlov2.Count Debug.Print "end " & Format(Timer - t, "0.00") End Sub
При этом, волею судеб _Boroda_, последние 4 столбца пустые
Хе-хе, а строка 532 и ниже?
Тоже работа с листом, а потом с массивом. 0,34 сек [vba]
Код
Sub KolDub1() t_ = Timer With Me.UsedRange: End With c0_ = 5 c_ = Cells(1).SpecialCells(xlLastCell).Column + 1 If c_ < c0_ Then Exit Sub r0_ = 1 nr_ = Cells(1).SpecialCells(xlLastCell).Row - r0_ + 1 If nr_ < 1 Then Exit Sub Application.ScreenUpdating = 0 cal_ = Application.Calculation Application.Calculation = 3 For i = 0 To c_ - c0_ - 1 Cells(r0_ + nr_ * i, c_).Resize(nr_) = Cells(r0_, c0_ + i).Resize(nr_).Value Next i With Me.Sort .SortFields.Add Key:=Cells(r0_, c0_ + i) .Apply End With n_ = Cells(Rows.Count, c0_ + i).End(3).Row ar = Cells(r0_, c0_ + i).Resize(n_) Cells(r0_, c0_ + i).Resize(n_).Clear With Me.UsedRange: End With For i = 1 To n_ - 1 If ar(i, 1) = ar(i + 1, 1) Then x_ = x_ + 1 If k_ = 0 Then x_ = x_ + 1 End If k_ = 1 Else k_ = 0 End If Next i Application.Calculation = cal_ Application.ScreenUpdating = 1 Cells(1, 2) = x_ Debug.Print "end " & Format(Timer - t_, "0.00") End Sub
При этом, волею судеб _Boroda_, последние 4 столбца пустые
Хе-хе, а строка 532 и ниже?
Тоже работа с листом, а потом с массивом. 0,34 сек [vba]
Код
Sub KolDub1() t_ = Timer With Me.UsedRange: End With c0_ = 5 c_ = Cells(1).SpecialCells(xlLastCell).Column + 1 If c_ < c0_ Then Exit Sub r0_ = 1 nr_ = Cells(1).SpecialCells(xlLastCell).Row - r0_ + 1 If nr_ < 1 Then Exit Sub Application.ScreenUpdating = 0 cal_ = Application.Calculation Application.Calculation = 3 For i = 0 To c_ - c0_ - 1 Cells(r0_ + nr_ * i, c_).Resize(nr_) = Cells(r0_, c0_ + i).Resize(nr_).Value Next i With Me.Sort .SortFields.Add Key:=Cells(r0_, c0_ + i) .Apply End With n_ = Cells(Rows.Count, c0_ + i).End(3).Row ar = Cells(r0_, c0_ + i).Resize(n_) Cells(r0_, c0_ + i).Resize(n_).Clear With Me.UsedRange: End With For i = 1 To n_ - 1 If ar(i, 1) = ar(i + 1, 1) Then x_ = x_ + 1 If k_ = 0 Then x_ = x_ + 1 End If k_ = 1 Else k_ = 0 End If Next i Application.Calculation = cal_ Application.ScreenUpdating = 1 Cells(1, 2) = x_ Debug.Print "end " & Format(Timer - t_, "0.00") End Sub
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
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
