Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel (архив)
Страницы: 1
RSS
Макрос ищущий одинаковые значения
 
#1
19.11.2010 00:02:05
Доброй ночи.  
Нужен макрос ищущий одинаковые значения в строках (будут ФИО и названия организаций), после чего он должен выводить сколько раз повторилась каждая ФИО или организация.  
Можно ли это сделать без введения списка ФИО или организаций, которые он (макрос) должен искать? Т.е. он сам должен проверить диапазон, выявить одинаковые, после чего вывести, что и сколько раз повторилось...
 
 
 
#2
19.11.2010 00:11:02
Доброй!  
Возможно, что макрос и не понадобится - достаточно будет функции СЧЕТЕСЛИ. Покажите небольшой пример с данными и с желаемым результатом.
 
 
 
#3
19.11.2010 00:18:47
{quote}{login=Юрий М}{date=19.11.2010 12:11}{thema=}{post}Доброй!  
Возможно, что макрос и не понадобится - достаточно будет функции СЧЕТЕСЛИ. Покажите небольшой пример с данными и с желаемым результатом.{/post}{/quote}  
 
Пример приложил, но строк будут тысячи и будут тысячи разных ФИО и организаций.
 
 
 
#4
19.11.2010 00:54:04
Писал код для точно такой задачи. Чуть только диапазоны поменял:  
 
Option Explicit  
Sub otbor()  
 
   Dim a(), oDict As Object, i As Long, Temp As String  
   Application.ScreenUpdating = False  
 
   a = Sheets(1).Range("A2:A" & Sheets(1).Range("A" & Rows.Count).End(xlUp).Row).Value  
   Set oDict = CreateObject("Scripting.Dictionary")  
   For i = 1 To UBound(a)  
       Temp = Trim(a(i, 1))  
       If Not oDict.Exists(Temp) Then  
           oDict.Add Temp, CStr(1)  
       Else  
           oDict.Item(Temp) = CStr(--oDict.Item(Temp) + 1)  
       End If  
   Next  
 
   With ThisWorkbook.Worksheets(1)  
       .Range("C1").Resize(oDict.Count) = Application.Transpose(oDict.keys)  
       .Range("D1").Resize(oDict.Count) = Application.Transpose(oDict.items)  
   End With  
 
End Sub
 
 
 
#5
19.11.2010 01:53:03
Огромная (незнающая границ) благодарность за решение проблемы! :)
 
 
 
#6
19.11.2010 01:58:59
Забыл строку лишнюю убрать -    
Application.ScreenUpdating = False  
Оно тут в общем в этой задаче ни к чему.  
Ну или в конце добавьте  
Application.ScreenUpdating = True
 
 
 
#7
19.11.2010 11:03:56
А вот так, ИМХО, ещё элегантнее:  
Sub NoDupesCount()  
  Dim Arr(), iArr  
  Arr = ActiveSheet.Range("A2:A" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row).Value  
  With CreateObject("Scripting.Dictionary")  
     For Each iArr In Arr  
     If Trim(iArr) <> "" Then .Item(Trim(iArr)) = .Item(Trim(iArr)) + 1  
     Next  
     ActiveSheet.Range("C1").Resize(.Count) = Application.Transpose(.Keys)  
     ActiveSheet.Range("D1").Resize(.Count) = Application.Transpose(.Items)  
  End With  
End Sub
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
 
 
#8
19.11.2010 11:10:48
А ещё корректнее, чтобы было текстовое сравнение (А=а, С=с, ...):  
Sub NoDupesCount()  
  Dim Arr(), iArr  
  Arr = ActiveSheet.Range("A2:A" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row).Value  
  With CreateObject("Scripting.Dictionary")  
     .CompareMode = vbTextCompare  
     For Each iArr In Arr  
        If Trim(iArr) <> "" Then .Item(Trim(iArr)) = .Item(Trim(iArr)) + 1  
     Next  
     ActiveSheet.Range("C2").Resize(.Count) = Application.Transpose(.Keys)  
     ActiveSheet.Range("D2").Resize(.Count) = Application.Transpose(.Items)  
  End With  
End Sub
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
 
 
Страницы: 1
Читают тему
Наверх