PavelO
Newbie | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
ProgrBoris2007
Вот код, который копирует фамилии. Разбирайтесь на здоровье. Так как я ограничен по времени, то код несколько убогий, но в целом функционирует:
Private Sub CommandButton1_Click()
Dim FFArr(), KolFFArr(), KolLast(), rowNum(), rowNum2()
Kol_vo = 101 'кол-во, которое нужно вывести
KolFF = 0
ReDim Preserve FFArr(0)
ReDim Preserve KolFFArr(0)
ReDim Preserve KolLast(0)
ReDim Preserve rowNum(33, 0)
y = 0
For i = 1 To UsedRange.Rows.Count
nachalo:
Set proverka = Sheets("Лист2").Columns("a:a").Find(Cells(i, 1)) 'проверяем не встречается ли эта фамилия на Листе2 в столбце a
If Not proverka Is Nothing Then 'если фамилия встречается - проверяем другие столбцы
If Sheets("Лист2").Cells(proverka.Row, 2) = Cells(i, 2) And Sheets("Лист2").Cells(proverka.Row, 3) = Cells(i, 3) Then
If i = UsedRange.Rows.Count Then
Exit Sub
End If
i = i + 1
GoTo nachalo 'выходим из цикла
End If
End If
ZapFF = True 'запись первой буквы фамилии разрешена
'Пробегаем по всем записанным буквам
For cFF = LBound(FFArr) To UBound(FFArr)
'cells(i,1) - i -строка, 1-столбец с фамилией
If FFArr(cFF) = Left(Cells(i, 1), 1) Then
ZapFF = False 'если первая буква уже встречалась, то запись запрещена
KolFFArr(cFF) = KolFFArr(cFF) + 1 'и прибавляем 1
If maxKol < KolFFArr(cFF) Then
ReDim Preserve rowNum(33, KolFFArr(cFF))
End If
rowNum(cFF, KolFFArr(cFF)) = i
If maxKol < KolFFArr(cFF) Then maxKol = KolFFArr(cFF)
End If
Next
If ZapFF = True Then
KolFF = KolFF + 1
rowNum(KolFF - 1, 0) = i
ReDim Preserve FFArr(KolFF - 1) 'меняем размерность
FFArr(KolFF - 1) = Left(Cells(i, 1), 1) 'записываем первую букву
ReDim Preserve KolFFArr(cFF)
KolFFArr(cFF) = 1 'Кол-во данных букв = 1
End If
Next
i = 0
ReDim Preserve KolLast(UBound(FFArr))
For cFF = LBound(FFArr) To UBound(FFArr)
KolLast(cFF) = Int(Kol_vo / KolFF)
Next
For cFF = LBound(FFArr) To UBound(FFArr)
line2: If i > UBound(FFArr) Then
i = 0
End If
If Kol_vo / KolFF <> Round(Kol_vo / KolFF, 0) And KolFFArr(cFF) > Round(Kol_vo / KolFF, 0) Then
If KolFFArr(i) > Round(Kol_vo / KolFF, 0) Then
KolLast(i) = KolLast(i) + 1
Kol_vo = Kol_vo - 1
End If
i = i + 1
GoTo line2:
ElseIf KolFFArr(cFF) < Round(Kol_vo / KolFF, 0) Then
KolLast(cFF) = Round(Kol_vo / KolFF, 0)
Do While KolFFArr(cFF) <> KolLast(cFF)
KolLast(cFF) = KolLast(cFF) - 1
line: If i > UBound(FFArr) Then
i = 0
End If
If KolLast(i) < KolFFArr(i) Then
KolLast(i) = KolLast(i) + 1
i = i + 1
Else
i = i + 1
GoTo line
End If
Loop
End If
Next
If Sheets("Лист2").Cells(1, 1) <> "" Then
Z = Sheets("Лист2").Cells(1, 1)
Else
Z = 2
End If
For i = LBound(KolFFArr) To UBound(KolFFArr)
r = 1
For y = 0 To KolFFArr(i)
If rowNum(i, y) <> Empty Then
If r > KolLast(i) Then
Exit For
End If
Sheets("Лист2").Cells(1, 1) = Z - 1
Sheets("Лист2").Cells(Z, 1) = Cells(rowNum(i, y), 1)
Sheets("Лист2").Cells(Z, 2) = Cells(rowNum(i, y), 2)
Z = Z + 1 ' строка на Листе2, в которую будем записывать
r = r + 1 'счетчик кол-ва записей на каждую букву
End If
Next
Next
End Sub
|
