Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Макрос сортировки и удаления дубликатов
 
#1
12.04.2021 11:40:16
Здравствуйте,

появилась задача обработать файл по следующим параметрам:

- в столбце А отсортировать во возрастающей данные
- после сортировки удалить все дубликаты
- после удаления дубликатов разбить все данные из столбца в строки по 9

Подскажите как (и возможно-ли) это сделать?
 
 
 
#2
12.04.2021 11:42:07
shamka, обычно тут задают 1 вопрос или просят помощи в исправлении или добавлении...
у Вас прям куча вопросов...
Код
Sub mrshkei()
Dim arr, i As Long, arr2, n As Long, lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
 Range("A2:A" & lr).Select
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Add Key:=Range("A2:A" & lr) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Лист1").Sort
        .SetRange Range("A1:A" & lr)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveSheet.Range("$A$1:$A$" & lr).RemoveDuplicates Columns:=1, Header:=xlYes
    
lr = Cells(Rows.Count, 1).End(xlUp).Row
arr = Range("A2:A" & lr)
ReDim arr2(1 To Int(lr / 9), 1 To 1): k = 1
For i = LBound(arr) To UBound(arr) Step 9
    For n = 1 To 9
        If arr2(k, 1) = Empty Then
            arr2(k, 1) = arr(i + n - 1, 1)
        Else
            arr2(k, 1) = arr2(k, 1) & " " & arr(i + n - 1, 1)
        End If
    Next n
    k = k + 1
Next i
Range("C1").Resize(UBound(arr2), 1) = arr2
Range("C1").Select
End Sub
Изменено: Mershik - 12.04.2021 12:49:31
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#3
12.04.2021 12:06:13
Код
Function GetArr(sh As Worksheet) As Variant
    With sh
        Dim y As Long
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        If y = 1 Then y = 2
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range(Cells(2, 1).Resize(y - 1).Address(0, 0)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange Range(Cells(2, 1).Resize(y - 1).Address(0, 0))
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        .Cells(1, 1).Resize(y).RemoveDuplicates Columns:=1, Header:=xlYes
        
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        If y < 3 Then y = 3
        Dim arr As Variant
        arr = .Range(.Cells(2, 1), .Cells(y, 1))
    End With
    
    GetArr = arr
End Function

Function GetBrr(arr As Variant) As Variant
    Dim y As Long
    Dim u As Long
    u = Int(UBound(arr, 1) / 9) + 1
    Dim brr As Variant
    Dim crr As Variant
    ReDim brr(1 To u, 1 To 1)
    u = 1
    Dim i As Byte
    u = 0
    For y = 1 To UBound(arr, 1)
        u = u + 1
        ReDim crr(1 To 9)
        For i = 1 To 9
            crr(i) = arr(y, 1)
            y = y + 1
            If y > UBound(arr, 1) Then Exit For
        Next
        brr(u, 1) = Join(crr, " ")
    Next
    GetBrr = brr
End Function

Sub Main()
    Dim arr As Variant
    Dim brr As Variant
    arr = GetArr(ActiveSheet)
    brr = GetBrr(arr)
    
    Workbooks.Add(1).Sheets(1).Cells(1, 1).Resize(UBound(brr, 1), 1) = brr
End Sub
 
 
 
#4
12.04.2021 12:33:32
Доброе время суток.
Если решение на Power Query сойдёт за макрос, то как-то где-то так
 
 
 
#5
12.04.2021 13:51:56
Спасибо всем за помощь! Подошел вариант от МатросНаЗебре.
 
 
 
#6
12.04.2021 14:37:35
Ну можно ещё так, первый вариант макросом
Код
Sub Макрос3()
    Dim SortedList, Sp1, Sp2
    Dim sl As String, n As Long, m As Long, z As Long
    Sp1 = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    Set SortedList = CreateObject("System.Collections.SortedList")
    For n = LBound(Sp1) To UBound(Sp1)
        If SortedList.ContainsKey(Sp1(n, 1)) = False Then
            SortedList.Add Sp1(n, 1), CStr(Sp1(n, 1))
        End If
    Next n
    z = IIf(SortedList.Count Mod 9 = 0, SortedList.Count / 9, Fix(SortedList.Count / 9) + 1)
    ReDim Sp2(1 To z, 1 To 1)
    m = 1
    For n = 0 To SortedList.Count - 1
        sl = sl & " " & SortedList.GetByIndex(n)
        If n = SortedList.Count - 1 And (n + 1) Mod 9 <> 0 Then Sp2(m, 1) = Mid(sl, 2)
        If (n + 1) Mod 9 = 0 Then Sp2(m, 1) = Mid(sl, 2): sl = "": m = m + 1
    Next n
    Range("C1:C" & z) = Sp2
End Sub


второй пользовательской функцией (вводится как формула массива)
Код
Function СОРТ_ПО_9(source As Range)
    Dim SortedList, Sp1, Sp2
    Dim sl As String, n As Long, m As Long
    Sp1 = source.Value
    Set SortedList = CreateObject("System.Collections.SortedList")
    For n = LBound(Sp1) To UBound(Sp1)
        If SortedList.ContainsKey(Sp1(n, 1)) = False Then
            SortedList.Add Sp1(n, 1), CStr(Sp1(n, 1))
        End If
    Next n
    ReDim Sp2(1 To IIf(SortedList.Count Mod 9 = 0, SortedList.Count / 9, Fix(SortedList.Count / 9) + 1), 1 To 1)
    m = 1
    For n = 0 To SortedList.Count - 1
        sl = sl & " " & SortedList.GetByIndex(n)
        If n = SortedList.Count - 1 And (n + 1) Mod 9 <> 0 Then Sp2(m, 1) = Mid(sl, 2)
        If (n + 1) Mod 9 = 0 Then Sp2(m, 1) = Mid(sl, 2): sl = "": m = m + 1
    Next n
    СОРТ_ПО_9 = Sp2
End Function
Изменено: msi2102 - 12.04.2021 14:57:19
 
 
 
Страницы: 1
Наверх