Доброго времени суток! Уважаемые форумчане помогите в решении задачки Необходимо посчитать количество дубликатов в столбце, которые выделяются условным форматированием и вывести количество в ячейку
Доброго времени суток! Уважаемые форумчане помогите в решении задачки Необходимо посчитать количество дубликатов в столбце, которые выделяются условным форматированием и вывести количество в ячейкуrtv206
Подскажите, пожалуйста, других способов нет? Очень сильно тормозит при большом количестве значений. Макросом например считать количество ячеек с условным форматированием?
Подскажите, пожалуйста, других способов нет? Очень сильно тормозит при большом количестве значений. Макросом например считать количество ячеек с условным форматированием?rtv206
let Источник = Excel.CurrentWorkbook(){[Name="Таблица1"]}[Content][Столбец1], dupl = Table.FromRecords({[Дубликаты =List.Count(Источник)-List.Count(List.Distinct(Источник))]}) in dupl
let Источник = Excel.CurrentWorkbook(){[Name="Таблица1"]}[Content][Столбец1], dupl = Table.FromRecords({[Дубликаты =List.Count(Источник)-List.Count(List.Distinct(Источник))]}) in dupl
Sub KolDub() c_ = 1 r0_ = 1 n_ = Cells(Rows.Count, c_).End(3).Row - r0_ + 1 ar = Cells(r0_, c_).Resize(n_) Set slov1 = CreateObject("Scripting.Dictionary") Set slov2 = CreateObject("Scripting.Dictionary") With slov1 For i = 1 To n_ If .exists(ar(i, 1)) Then z_ = z_ + 1 aaa = slov2.Item(ar(i, 1)) Else aaa = .Item(ar(i, 1)) End If Next i End With Cells(1, 6) = z_ + slov2.Count End Sub
[/vba]
Ловите макросом с кнопки [vba]
Код
Sub KolDub() c_ = 1 r0_ = 1 n_ = Cells(Rows.Count, c_).End(3).Row - r0_ + 1 ar = Cells(r0_, c_).Resize(n_) Set slov1 = CreateObject("Scripting.Dictionary") Set slov2 = CreateObject("Scripting.Dictionary") With slov1 For i = 1 To n_ If .exists(ar(i, 1)) Then z_ = z_ + 1 aaa = slov2.Item(ar(i, 1)) Else aaa = .Item(ar(i, 1)) End If Next i End With Cells(1, 6) = z_ + slov2.Count End Sub
Если ответов нет, то скорее всего что-то не так в вопросе. В Вашем вопросе по крайней мере два нетака - 1, Нет файла-примера с данными в столбцах Е:Z 2. Не определено понятие дубликатов в разных столбцах - если в столбце Е значения а,в,в; в столбце F значения с,d,а, то понятно, что в - дубликат, но вот дубликат ли а?
Если ответов нет, то скорее всего что-то не так в вопросе. В Вашем вопросе по крайней мере два нетака - 1, Нет файла-примера с данными в столбцах Е:Z 2. Не определено понятие дубликатов в разных столбцах - если в столбце Е значения а,в,в; в столбце F значения с,d,а, то понятно, что в - дубликат, но вот дубликат ли а?_Boroda_
2. Не определено понятие дубликатов в разных столбцах - если в столбце Е значения а,в,в; в столбце F значения с,d,а, то понятно, что в - дубликат, но вот дубликат ли а?
2. Не определено понятие дубликатов в разных столбцах - если в столбце Е значения а,в,в; в столбце F значения с,d,а, то понятно, что в - дубликат, но вот дубликат ли а?
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_) Set slov1 = CreateObject("Scripting.Dictionary") Set slov2 = CreateObject("Scripting.Dictionary") With slov1 For i = 1 To nr_ For j = 1 To nc_ If Not IsEmpty(ar(i, j)) Then If .exists(ar(i, j)) Then z_ = z_ + 1 aaa = slov2.Item(ar(i, j)) Else aaa = .Item(ar(i, j)) End If End If Next j Next i End With Cells(1, 2) = z_ + slov2.Count 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_) Set slov1 = CreateObject("Scripting.Dictionary") Set slov2 = CreateObject("Scripting.Dictionary") With slov1 For i = 1 To nr_ For j = 1 To nc_ If Not IsEmpty(ar(i, j)) Then If .exists(ar(i, j)) Then z_ = z_ + 1 aaa = slov2.Item(ar(i, j)) Else aaa = .Item(ar(i, j)) End If End If Next j Next i End With Cells(1, 2) = z_ + slov2.Count End Sub
Поменял порядок циклов, и погонял. Результат не утешительный. [vba]
Код
Sub KolDub() Dim t!, tt! 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_) Set slov1 = CreateObject("Scripting.Dictionary") Set slov2 = CreateObject("Scripting.Dictionary") tt = Timer With slov1 For j = 1 To nc_ For i = 1 To nr_ If Not IsEmpty(ar(i, j)) Then If .exists(ar(i, j)) Then z_ = z_ + 1 aaa = slov2.Item(ar(i, j)) Else aaa = .Item(ar(i, j)) End If End If Next Debug.Print j & "j " & Format(Timer - tt, "0.00") tt = Timer DoEvents Next
End With Debug.Print "end " & Format(Timer - t, "0.00") Cells(1, 2) = z_ + slov2.Count End Sub
[/vba] 1j 0,40 2j 1,16 3j 1,88 4j 2,65 5j 3,53 6j 4,60 7j 5,66 8j 6,51 9j 7,34 10j 8,14 11j 8,98 12j 9,80 13j 10,63 14j 11,53 15j 12,31 16j 13,20 17j 13,98 18j 14,82 19j 15,73 20j 16,47 21j 17,27 22j 18,11 23j 18,92 24j 20,02 25j 22,44 26j 21,63 27j 22,48 28j 19,68 29j 20,22 30j 20,85 31j 21,53 end 392,59 При этом, волею судеб _Boroda_, последние 4 столбца пустые, и время на их обработку меня вообще ставит в тупик.
Поменял порядок циклов, и погонял. Результат не утешительный. [vba]
Код
Sub KolDub() Dim t!, tt! 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_) Set slov1 = CreateObject("Scripting.Dictionary") Set slov2 = CreateObject("Scripting.Dictionary") tt = Timer With slov1 For j = 1 To nc_ For i = 1 To nr_ If Not IsEmpty(ar(i, j)) Then If .exists(ar(i, j)) Then z_ = z_ + 1 aaa = slov2.Item(ar(i, j)) Else aaa = .Item(ar(i, j)) End If End If Next Debug.Print j & "j " & Format(Timer - tt, "0.00") tt = Timer DoEvents Next
End With Debug.Print "end " & Format(Timer - t, "0.00") Cells(1, 2) = z_ + slov2.Count End Sub
[/vba] 1j 0,40 2j 1,16 3j 1,88 4j 2,65 5j 3,53 6j 4,60 7j 5,66 8j 6,51 9j 7,34 10j 8,14 11j 8,98 12j 9,80 13j 10,63 14j 11,53 15j 12,31 16j 13,20 17j 13,98 18j 14,82 19j 15,73 20j 16,47 21j 17,27 22j 18,11 23j 18,92 24j 20,02 25j 22,44 26j 21,63 27j 22,48 28j 19,68 29j 20,22 30j 20,85 31j 21,53 end 392,59 При этом, волею судеб _Boroda_, последние 4 столбца пустые, и время на их обработку меня вообще ставит в тупик.RAN
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
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
