Страницы: 1
RSS
Выбор первых 10 строк, Нужно сделать выборку по 10 строк относительно значения в первом столбце
 
Добрый день.
Выручайте. Есть файл, первый столбец города , второй адреса. Кол-во разное.
Нужно выбрать 10 адресов по каждому городу ( любые 10) не больше 10.

Чтобы получилось:
Город1 - Адрес1
Город1 - Адрес2
и так 10 шт
.......
Город2 - Адрес1
Город2 - Адрес2
и т.п

Было бы круто если бы кто-нибудь придумал макрос, чтобы в дальнейшем я смог задавать любое кол-во строк для выборки. Отблагодарю финансово

---- Задача немного усложнилась ( макрос по верхней задаче уже готов, ниже в сообщениях)  

В макрос добавить чтобы можно было выбрать по сколько строк делать выборку и добавить проверку, если адрес совпадает то подставлять другой. Если адресов недостаточно для подстановки ( например их всего 10) а выборку ставлю 15, тогда кол-во городов должно быть 15 - первый столбец, а во втором вместо повторяющегося адреса название города.
Изменено: Дмитрий С - 29.11.2023 04:53:48
 
Такую формулу в С2 и протяните вниз, затем в фильтре установите меньше или рано 10
Код
=СЧЁТЕСЛИ($A$2:A2;A2)
Изменено: Msi2102 - 28.11.2023 14:37:48
 
Msi2102, Благодарю. Отправьте номер карты переведу  
 
Цитата
Дмитрий С написал:
Отправьте номер карты переведу  
Это бесплатная ветка, пользуйтесь (файл обрезал, а то не помещается) :D
Изменено: Msi2102 - 28.11.2023 14:40:58
 
Цитата
написал:
придумал макрос
 
Код
Option Explicit

Sub myAddress()
    Dim nn As Long
    nn = Application.InputBox("Введите число", Default:=10, Type:=1)
    If nn < 1 Then Exit Sub
    
    Dim arr As Variant
    arr = GetArr(Columns("A:B"))
    
    Dim dic As Object
    Set dic = GetDic(arr)
    arr = Empty
    If dic.Count = 0 Then Exit Sub
    
    arr = LeaveN(dic, nn)
    Set dic = Nothing
    
    PrintArr arr
End Sub

Private Sub PrintArr(arr As Variant)
    ActiveSheet.Copy
    ActiveSheet.Cells.ClearContents
    
    With ActiveWorkbook
        With .Sheets(1)
            With .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
                .Value = arr
            End With
        End With
    End With
End Sub

Private Function LeaveN(dic As Object, nn As Long) As Variant
    Dim arr As Variant
    ReDim arr(1 To nn * dic.Count, 1 To 2)
    Dim bic As Object
    
    Dim ni As Long
    Dim yd As Long
    Dim ya As Long
    Dim vKey As Variant
    For Each vKey In dic.Keys
        Set bic = dic.Item(vKey)
        For ni = 1 To nn
            If bic.Count = 0 Then Exit For
            yd = (bic.Count - 1) * Rnd()
            ya = ya + 1
            arr(ya, 1) = vKey
            arr(ya, 2) = bic.Keys()(yd)
            bic.Remove bic.Keys()(yd)
        Next
    Next
    
    LeaveN = arr
End Function

Private Function GetDic(arr As Variant) As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        If Not dic.Exists(arr(ya, 1)) Then
            Set dic.Item(arr(ya, 1)) = CreateObject("Scripting.Dictionary")
        End If
    Next
    
    For ya = 1 To UBound(arr, 1)
        dic.Item(arr(ya, 1)).Item(arr(ya, 2)) = 0
    Next
    
    Set GetDic = dic
End Function

Private Function GetArr(rr As Range) As Variant
    GetArr = Intersect(rr, rr.Parent.UsedRange).Value
End Function
 
kekoyit, а можно в макрос добавить чтобы можно было выбрать по сколько строк делать выборку и добавить проверку, если адрес совпадает то подставлять другой. Если адресов недостаточно для подстановки ( например их всего 10) а выборку ставлю 15, тогда кол-во городов должно быть 15 - первый столбец, а во втором вместо повторяющегося адреса название города.
Страницы: 1
Наверх