Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Вывести из массива уникальные значения
 
#1
06.11.2022 03:50:13
Всем здравствуйте, подскажите, пожалуйста, прошу помочь знающих людей, поправить код таким образом, чтобы выводились уникальные значения на лист2 из массива. Нужно чтобы уникальные значения находились сцепкой данных с листа1, столбцы B,C,E.
У меня получилось только внести данные в массив с листа1 и выгружать их на лист2 в нужные столбцы.
Изменено: skorlink - 06.11.2022 15:26:20
 
 
 
#2
06.11.2022 23:06:12
Здравствуйте.
Попробуйте таким, может:
Код
Sub Move_Uniq()
    Dim arrIn, Uniq As New Collection, i%
    Worksheets("лист2").Range("B2").CurrentRegion.ClearContents
    arrIn = Worksheets("лист1").Range("B2").CurrentRegion.Value
    On Error Resume Next
    For i = 1 To UBound(arrIn, 1)
        Uniq.Add Item:=arrIn(i, 1) & "-" & arrIn(i, 2) & "-" & arrIn(i, 4), Key:=arrIn(i, 1) & "-" & arrIn(i, 2) & "-" & arrIn(i, 4)
    Next i
    With Worksheets("лист2")
        For i = 1 To Uniq.Count
            .Range("B" & i + 1).Resize(1, 3) = Split(Uniq.Item(i), "-")
        Next i
        .Range("B2").CurrentRegion.Columns(3) = .Range("B2").CurrentRegion.Columns(3).Value
    End With
End Sub
Кому решение нужно - тот пример и рисует.
 
 
 
#3
07.11.2022 03:37:52
Пытливый, спасибо огромное, к сожалению, большое количество строк обрабатывает долго, даже с отключенным обновлением экрана и перерасчетом формул.
 
 
 
#4
07.11.2022 04:44:56
Код
Sub MoveUnique()
    Dim Dict As Object, arrIn As Variant, arrOut As Variant, i As Long, str As String, Counter As Long
    
    Worksheets("лист2").Range("B2").CurrentRegion.ClearContents
    arrIn = Worksheets("лист1").Range("B2").CurrentRegion.Value
    ReDim arrOut(1 To UBound(arrIn, 1), 1 To 3)
    
    Set Dict = CreateObject("Scripting.Dictionary")
    
    For i = 1 To UBound(arrIn, 1)
        str = arrIn(i, 1) & "-" & arrIn(i, 2) & "-" & arrIn(i, 4)
        If Not Dict.Exists(str) Then
            Dict(str) = 0&
            Counter = Counter + 1
            arrOut(Counter, 1) = arrIn(i, 1)
            arrOut(Counter, 2) = arrIn(i, 2)
            arrOut(Counter, 3) = arrIn(i, 4)
        End If
    Next i
        
    With Worksheets("лист2")
        .Range("B2").Resize(Counter, UBound(arrOut, 2)).Value = arrOut
    End With
    
    MsgBox "Уникальные скопированы на лист 2", vbInformation, "Конец"
End Sub
 
 
 
#5
07.11.2022 05:24:06
New, благодарю Вас, всё летает.
 
 
 
#6
07.11.2022 07:48:55
У меня давно уже в Personal лежит макрос для поиска уникальных значений в выделенном диапазоне.
Попробуйте:
Код
Sub NoDups_in_Range()
'---------------------------------------------------------------------------------------
' Procedure    : NoDups_in_Range
' Author       : Alex_ST
' Topic_HEADER : Макрос "NoDups_in_Range" (Подсчёт и вывод уникальных значений в диапазоне)
' Topic_URL    : http://www.excelworld.ru/forum/3-39-25849-16-1347208019
' Purpose      : вывод списка уникальных значений из ВИДИМЫХ ячеек задаваемого диапазона с возможностью подсчёта числа повторов
'---------------------------------------------------------------------------------------
   Dim Addr, rRng As Range, rCell As Range
   On Error Resume Next
   '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
   ' замена Application.InputBox("...", "...", Type:=8), не работающего на других листах и листах с УФ формулой
   Addr = Application.InputBox("Где брать список?", "Выбор диапазона данных", "=" & Selection.Address, Type:=0)
   If TypeName(Addr) = "Boolean" Then Exit Sub    ' если нажали "Отмена", то Addr = False
   Addr = Range(Trim(Mid(Application.ConvertFormula(Addr, xlR1C1, xlA1, True), 2))).AddressLocal(0, 0, 1, 1)
   '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
   Set rRng = Intersect(Range(Addr).Parent.UsedRange, Range(Addr).Parent.Cells.SpecialCells(xlCellTypeVisible), Range(Addr)): If Err Then Exit Sub
   With CreateObject("Scripting.Dictionary"): .CompareMode = vbTextCompare   ' создаем временный словарь
      For Each rCell In rRng
         If Trim(rCell) <> "" Then .Item(Trim(rCell)) = .Item(Trim(rCell)) + 1   ' попытка записи значения по отсутствующему ключу добавит ключ в словарь
      Next
      If MsgBox("Видимые ячейки указанного диапазона содержат " & vbCrLf & .Count & " уникальных значений." & vbCrLf & _
                "Вывести список на лист?", vbYesNo Or vbInformation, "Параметры списка") = vbNo Then Exit Sub
      '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
      ' замена Application.InputBox("...", "...", Type:=8), не работающего на других листах и листах с УФ формулой
      Addr = Application.InputBox("Куда выводить список?", "Выбор диапазона данных", "=" & Selection(1).Address, Type:=0)
      If TypeName(Addr) = "Boolean" Then Exit Sub   ' если нажали "Отмена", то Addr = False
      Addr = Range(Trim(Mid(Application.ConvertFormula(Addr, xlR1C1, xlA1, True), 2))).AddressLocal(0, 0, 1, 1)
      '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
      Range(Range(Addr)(1, 1), Range(Addr)(.Count, 1)).Value = Application.WorksheetFunction.Transpose(.Keys)
      Range(Addr).Parent.Activate  ' перейти к листу, куда выводятся данные
      If MsgBox("Вывести количества в соседний столбец?", vbQuestion + vbYesNo, "Вывод данных") = vbYes Then
         Range(Range(Addr)(1, 2), Range(Addr)(.Count, 2)).NumberFormat = "General"
         Range(Range(Addr)(1, 2), Range(Addr)(.Count, 2)).Value = Application.WorksheetFunction.Transpose(.Items)
         Range(Range(Addr)(1, 1), Range(Addr)(.Count, 2)).Activate  ' выделить диапазон выведенных данных
      Else
         Range(Range(Addr)(1, 1), Range(Addr)(.Count, 1)).Activate  ' выделить диапазон выведенных данных
      End If
   End With
End Sub
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
 
 
Страницы: 1
Наверх