Доброго дня! уважаемые форумчане! Возникла необходимость собрать массив и равномерно распределить в ТРИ строки. Как собрать в одну строку через пробелы и запятую знаю, а вот в три и равномерно никак не соображу. За любую помощь буду признателен.
Доброго дня! уважаемые форумчане! Возникла необходимость собрать массив и равномерно распределить в ТРИ строки. Как собрать в одну строку через пробелы и запятую знаю, а вот в три и равномерно никак не соображу. За любую помощь буду признателен.ZamoK
ZamoK, а если общее кол-во не делится на 3? приоритет 1я из трёх строк? и порядок расброса не важен? можно 1-в 1-ю, 2- во 2-ю, 3-ю в 3-ю строчку. А можно 1,2,3 в 1-ю строчку, далее 4,5,6 во 2-ю, 7,8,9,10 в 3-ю...
ZamoK, а если общее кол-во не делится на 3? приоритет 1я из трёх строк? и порядок расброса не важен? можно 1-в 1-ю, 2- во 2-ю, 3-ю в 3-ю строчку. А можно 1,2,3 в 1-ю строчку, далее 4,5,6 во 2-ю, 7,8,9,10 в 3-ю...Roman777
Sub Макрос1() Dim s As String, Count As Integer dx = Range("C4:E52") For n = 1 To UBound(dx) If dx(n, 1) <> "" Then s = s & "|" & dx(n, 2) & " " & dx(n, 1) & " - " & dx(n, 3) End If Next Z = Split(s, "|") Count = UBound(Z) / 3 ReDim X(1 To 3, 1 To 1) For n = 1 To UBound(Z) Select Case n Case Is <= Count X(1, 1) = X(1, 1) & "," & Z(n) Case Count + 1 To 2 * Count X(2, 1) = X(2, 1) & "," & Z(n) Case Else X(3, 1) = X(3, 1) & "," & Z(n) End Select
Sub Макрос1() Dim s As String, Count As Integer dx = Range("C4:E52") For n = 1 To UBound(dx) If dx(n, 1) <> "" Then s = s & "|" & dx(n, 2) & " " & dx(n, 1) & " - " & dx(n, 3) End If Next Z = Split(s, "|") Count = UBound(Z) / 3 ReDim X(1 To 3, 1 To 1) For n = 1 To UBound(Z) Select Case n Case Is <= Count X(1, 1) = X(1, 1) & "," & Z(n) Case Count + 1 To 2 * Count X(2, 1) = X(2, 1) & "," & Z(n) Case Else X(3, 1) = X(3, 1) & "," & Z(n) End Select
doober, Хорошо но слишком много, текст надо собрать до первой пустой строки, т.е. номер узла слева в таблице, и собирать надо только его составляющие, (справа которые) до первого пробела и эти делали уложить в три строки
doober, Хорошо но слишком много, текст надо собрать до первой пустой строки, т.е. номер узла слева в таблице, и собирать надо только его составляющие, (справа которые) до первого пробела и эти делали уложить в три строкиZamoK
Function co(s As String, n%, Optional nDel% = 3) Dim r As Range, mF, ii&, st&, f& ReDim mF(0 To 0) Set r = Columns("a:a").Find(What:=s, After:=Cells(1, 1), LookIn:=xlFormulas _ , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False)
Do Until Len(r.Offset(i, 2)) = 0 ReDim Preserve mF(i) mF(i) = r.Offset(i, 3) & " " & r.Offset(i, 2) & " " & r.Offset(i, 4) & " шт." i = i + 1 Loop i = i - 1
If n = 1 Then st = 0 Else st = Int(i / nDel * (n - 1)) + 1 If n = nDel Then f = i Else f = Int(i / nDel * (n))
For i = st To f - 1 co = co & mF(i) & vbLf '", " Next co = co & mF(f) End Function
[/vba] Разделитель потом поставите какой нужно - вместо vbLf . Просто так нагляднее. С такой UDF - можете делить на 3и, 4е ... кусков. Формула "заточена" под пример.
Сделал UDF кой: [vba]
Код
Function co(s As String, n%, Optional nDel% = 3) Dim r As Range, mF, ii&, st&, f& ReDim mF(0 To 0) Set r = Columns("a:a").Find(What:=s, After:=Cells(1, 1), LookIn:=xlFormulas _ , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False)
Do Until Len(r.Offset(i, 2)) = 0 ReDim Preserve mF(i) mF(i) = r.Offset(i, 3) & " " & r.Offset(i, 2) & " " & r.Offset(i, 4) & " шт." i = i + 1 Loop i = i - 1
If n = 1 Then st = 0 Else st = Int(i / nDel * (n - 1)) + 1 If n = nDel Then f = i Else f = Int(i / nDel * (n))
For i = st To f - 1 co = co & mF(i) & vbLf '", " Next co = co & mF(f) End Function
[/vba] Разделитель потом поставите какой нужно - вместо vbLf . Просто так нагляднее. С такой UDF - можете делить на 3и, 4е ... кусков. Формула "заточена" под пример.SLAVICK
Вот так будет работать - добавил еще одну переменную. [vba]
Код
Function co(s As String, rf As Range, n%, Optional nDel% = 3) Dim r As Range, mF, ii&, st&, f& ReDim mF(0 To 0) With rf.Parent Set r = rf.Find(What:=s, After:=.Cells(1, 1), LookIn:=xlFormulas _ , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False)
Do Until Len(r.Offset(i, 2)) = 0 mF(i) = r.Offset(i, 3) & " " & r.Offset(i, 2) & " " & r.Offset(i, 4) & " шт." i = i + 1 ReDim Preserve mF(i) Loop i = i - 1 End With If n = 1 Then st = 0 Else st = Int(i / nDel * (n - 1)) + 1 If n = nDel Then f = i Else f = Int(i / nDel * (n))
For i = st To f - 1 co = co & mF(i) & vbLf '", " Next co = co & mF(f) End Function
Вот так будет работать - добавил еще одну переменную. [vba]
Код
Function co(s As String, rf As Range, n%, Optional nDel% = 3) Dim r As Range, mF, ii&, st&, f& ReDim mF(0 To 0) With rf.Parent Set r = rf.Find(What:=s, After:=.Cells(1, 1), LookIn:=xlFormulas _ , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False)
Do Until Len(r.Offset(i, 2)) = 0 mF(i) = r.Offset(i, 3) & " " & r.Offset(i, 2) & " " & r.Offset(i, 4) & " шт." i = i + 1 ReDim Preserve mF(i) Loop i = i - 1 End With If n = 1 Then st = 0 Else st = Int(i / nDel * (n - 1)) + 1 If n = nDel Then f = i Else f = Int(i / nDel * (n))
For i = st To f - 1 co = co & mF(i) & vbLf '", " Next co = co & mF(f) End Function
Ещё один маленький вопрос, если состоит из 2 комплектующих, как убрать повторение первой ? Убрал значение первой ячейки условным форматированием по равенству, но может как-то в коде?
Ещё один маленький вопрос, если состоит из 2 комплектующих, как убрать повторение первой ? Убрал значение первой ячейки условным форматированием по равенству, но может как-то в коде?ZamoK
Function co(s As String, rf As Range, n%, Optional nDel% = 3) Dim r As Range, mF, ii&, st&, f& ReDim mF(0 To 0) With rf.Parent Set r = rf.Find(What:=s, After:=.Cells(1, 1), LookIn:=xlFormulas _ , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False)
Do Until Len(r.Offset(I, 2)) = 0 mF(I) = r.Offset(I, 3) & " " & r.Offset(I, 2) & " " & r.Offset(I, 4) & " øò." I = I + 1 ReDim Preserve mF(I) Loop I = I - 1 End With
If n > I + 1 Then co = "": Exit Function If n = 1 Then st = 0 Else st = Int(I / nDel * (n - 1)) + 1 If n = nDel Or n > I Then f = I Else f = Int(I / nDel * (n))
For I = st To f - 1 co = co & mF(I) & vbLf '", " Next co = co & mF(f) End Function
Function co(s As String, rf As Range, n%, Optional nDel% = 3) Dim r As Range, mF, ii&, st&, f& ReDim mF(0 To 0) With rf.Parent Set r = rf.Find(What:=s, After:=.Cells(1, 1), LookIn:=xlFormulas _ , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False)
Do Until Len(r.Offset(I, 2)) = 0 mF(I) = r.Offset(I, 3) & " " & r.Offset(I, 2) & " " & r.Offset(I, 4) & " øò." I = I + 1 ReDim Preserve mF(I) Loop I = I - 1 End With
If n > I + 1 Then co = "": Exit Function If n = 1 Then st = 0 Else st = Int(I / nDel * (n - 1)) + 1 If n = nDel Or n > I Then f = I Else f = Int(I / nDel * (n))
For I = st To f - 1 co = co & mF(I) & vbLf '", " Next co = co & mF(f) End Function
Function co(s As String, rf As Range, n%, Optional nDel% = 3) Dim k, r As Range, mF, ii&, st&, f& ReDim mF(0 To 0) With rf.Parent Set r = rf.Find(What:=s, After:=.Cells(1, 1), LookIn:=xlFormulas _ , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False)
Do Until Len(r.Offset(i, 2)) = 0 k = [r4] mF(i) = r.Offset(i, 3) & " " & r.Offset(i, 2) & "-(" & (r.Offset(i, 4)) * k & "шт.)" i = i + 1 ReDim Preserve mF(i) Loop i = i - 1 End With
If n > i + 1 Then co = "": Exit Function If n = 1 Then st = 0 Else st = Int(i / nDel * (n - 1)) + 1 If n = nDel Or n > i Then f = i Else f = Int(i / nDel * (n))
For i = st To f - 1 co = co & mF(i) & vbCr & ", " Next co = co & mF(f) End Function
[/vba]
как сделать чтоб функция срабатывала при изменении переменной?
Дополнил переменную ( k = [r4]) в кол-во,
[vba]
Код
Function co(s As String, rf As Range, n%, Optional nDel% = 3) Dim k, r As Range, mF, ii&, st&, f& ReDim mF(0 To 0) With rf.Parent Set r = rf.Find(What:=s, After:=.Cells(1, 1), LookIn:=xlFormulas _ , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False)
Do Until Len(r.Offset(i, 2)) = 0 k = [r4] mF(i) = r.Offset(i, 3) & " " & r.Offset(i, 2) & "-(" & (r.Offset(i, 4)) * k & "шт.)" i = i + 1 ReDim Preserve mF(i) Loop i = i - 1 End With
If n > i + 1 Then co = "": Exit Function If n = 1 Then st = 0 Else st = Int(i / nDel * (n - 1)) + 1 If n = nDel Or n > i Then f = i Else f = Int(i / nDel * (n))
For i = st To f - 1 co = co & mF(i) & vbCr & ", " Next co = co & mF(f) End Function
[/vba]
как сделать чтоб функция срабатывала при изменении переменной?ZamoK
Я не Гуру, но стремлюсь!
Сообщение отредактировал ZamoK - Четверг, 28.04.2016, 12:26
По всей видимости, сие волшебство не возможно? Почему-то не верю я, что excel это не под силу? Кнопкой реализовал через "грязные ячейки", а вот тут как ? [moder]Что Вы хотите сделать? Где пример с пояснениями?[/moder]
По всей видимости, сие волшебство не возможно? Почему-то не верю я, что excel это не под силу? Кнопкой реализовал через "грязные ячейки", а вот тут как ? [moder]Что Вы хотите сделать? Где пример с пояснениями?[/moder]ZamoK
Я не Гуру, но стремлюсь!
Сообщение отредактировал SLAVICK - Пятница, 29.04.2016, 16:51