Добрый день Нужно из каждого подмассива столбца 3 скопировать и вставить в столбец 6 значения, если: 1. В столбце 4 стоит "1" 2. Подмассив начинается от второй строчки (а также от ячейки в 4 столбце, содержащей "Ред") 3. Подмассив заканчивается перед ячейкой в 4 столбце, содержащей "Ред" (т.е. минус 1 строку) 4. Весь массив содержит неограниченное количество подмассивов (не более 1 тыс. строк) Вставлять значения через запятую в ячейку Cells(2,1), от содержащей "Ред" в 4 столбце Помощи вашей прошу. Мы похожее решали и я примерно понял, но не знаю как указать где искать. Понимаю, что нужно найти в первом подмассиве и циклом пройтись по всем массивам, ... Конец подмассива не знаю как указать. Думал через find.
Добрый день Нужно из каждого подмассива столбца 3 скопировать и вставить в столбец 6 значения, если: 1. В столбце 4 стоит "1" 2. Подмассив начинается от второй строчки (а также от ячейки в 4 столбце, содержащей "Ред") 3. Подмассив заканчивается перед ячейкой в 4 столбце, содержащей "Ред" (т.е. минус 1 строку) 4. Весь массив содержит неограниченное количество подмассивов (не более 1 тыс. строк) Вставлять значения через запятую в ячейку Cells(2,1), от содержащей "Ред" в 4 столбце Помощи вашей прошу. Мы похожее решали и я примерно понял, но не знаю как указать где искать. Понимаю, что нужно найти в первом подмассиве и циклом пройтись по всем массивам, ... Конец подмассива не знаю как указать. Думал через find.timo64uk
Добрый.Было же в моих макросах разделение на подмассивы.
Sub Test4() Dim Sh As Worksheet, Key$, A(), Count& Set Sh = ActiveSheet
LastRow = Sh.Cells(Sh.Rows.Count, 4).End(xlUp).Row Set List = CreateObject("scripting.dictionary")
dx = Sh.Range("A1:D" & LastRow)
Count = 0 For n = 1ToUBound(dx)
Key = dx(n, 4) If Key = "Ред"Then
Count = Count + 1
List.Item(Count) = Array(n + 1, n + 1) Else If Count > 0Then
A = List.Item(Count)
A(1) = n
List.Item(Count) = A EndIf EndIf Next
Items = List.Items For n = 0To List.Count - 1
A = Items(n)
rowStart = A(0)
rowEnd = A(1)
Key = "" For i = rowStart To rowEnd If dx(i, 4) = 1Then
Key = IIf(Key = "", dx(i, 3), Key & "," & dx(i, 3)) EndIf Next
Sh.Cells(rowStart, 6) = Key Next EndSub
Добрый.Было же в моих макросах разделение на подмассивы.
Sub Test4() Dim Sh As Worksheet, Key$, A(), Count& Set Sh = ActiveSheet
LastRow = Sh.Cells(Sh.Rows.Count, 4).End(xlUp).Row Set List = CreateObject("scripting.dictionary")
dx = Sh.Range("A1:D" & LastRow)
Count = 0 For n = 1ToUBound(dx)
Key = dx(n, 4) If Key = "Ред"Then
Count = Count + 1
List.Item(Count) = Array(n + 1, n + 1) Else If Count > 0Then
A = List.Item(Count)
A(1) = n
List.Item(Count) = A EndIf EndIf Next
Items = List.Items For n = 0To List.Count - 1
A = Items(n)
rowStart = A(0)
rowEnd = A(1)
Key = "" For i = rowStart To rowEnd If dx(i, 4) = 1Then
Key = IIf(Key = "", dx(i, 3), Key & "," & dx(i, 3)) EndIf Next
Sh.Cells(rowStart, 6) = Key Next EndSub
Спасибо большое. Да, с подмассивами было ваше решение от предыдущей темы (приложил файл с до и после его проигрывания)
'от doober Dim rng2 As Range, Aa(), Sh2 As Worksheet Set rng2 = Selection Set Sh2 = rng2.Parent
RowStart& = rng2(1, 1).Row
dx = rng2 Set List = CreateObject("scripting.dictionary") For n2 = 1ToUBound(dx)
Key$ = dx(n2, 1) If Key <> ""Then'пробелы игнорируем If n2 = UBound(dx) Then
Keys = Split(Key, ", ") 'раскладываем в нижней с запятой пробелом For Each Key_ In Keys If List.Exists(Key_) Then
Aa = List.Item(Key_)
paralast = UBound(Aa) + 1 ReDim Preserve Aa(paralast)
Aa(paralast) = n2 - 1 + RowStart
List.Item(Key_) = Aa Else
List.Item(Key_) = Array(n2 - 1 + RowStart) EndIf Next Else If List.Exists(Key) Then
Aa = List.Item(Key)
paralast = UBound(Aa) + 1 ReDim Preserve Aa(paralast)
Aa(paralast) = n2 - 1 + RowStart
List.Item(Key) = Aa Else
List.Item(Key) = Array(n2 - 1 + RowStart) EndIf EndIf EndIf Next Set rng2 = Nothing
Items = List.Items For n2 = 0To List.Count - 1
Aa = Items(n2) For i2 = 1ToUBound(Aa) - 1 If rng2 IsNothingThen Set rng2 = Sh2.Cells(Aa(i2), 1) Else Set rng2 = Union(rng2, Sh2.Cells(Aa(i2), 1)) EndIf Next Next IfNot rng2 IsNothingThen
rng2.EntireRow.Delete EndIf
Я пока не смог бы с ним совладать)). С двумя схожими кодами проще провести аналогии и выяснить суть. Восхитительно работает код. Только что его испробовал и начал разбирать. Спасибо.
Спасибо большое. Да, с подмассивами было ваше решение от предыдущей темы (приложил файл с до и после его проигрывания)
'от doober Dim rng2 As Range, Aa(), Sh2 As Worksheet Set rng2 = Selection Set Sh2 = rng2.Parent
RowStart& = rng2(1, 1).Row
dx = rng2 Set List = CreateObject("scripting.dictionary") For n2 = 1ToUBound(dx)
Key$ = dx(n2, 1) If Key <> ""Then'пробелы игнорируем If n2 = UBound(dx) Then
Keys = Split(Key, ", ") 'раскладываем в нижней с запятой пробелом For Each Key_ In Keys If List.Exists(Key_) Then
Aa = List.Item(Key_)
paralast = UBound(Aa) + 1 ReDim Preserve Aa(paralast)
Aa(paralast) = n2 - 1 + RowStart
List.Item(Key_) = Aa Else
List.Item(Key_) = Array(n2 - 1 + RowStart) EndIf Next Else If List.Exists(Key) Then
Aa = List.Item(Key)
paralast = UBound(Aa) + 1 ReDim Preserve Aa(paralast)
Aa(paralast) = n2 - 1 + RowStart
List.Item(Key) = Aa Else
List.Item(Key) = Array(n2 - 1 + RowStart) EndIf EndIf EndIf Next Set rng2 = Nothing
Items = List.Items For n2 = 0To List.Count - 1
Aa = Items(n2) For i2 = 1ToUBound(Aa) - 1 If rng2 IsNothingThen Set rng2 = Sh2.Cells(Aa(i2), 1) Else Set rng2 = Union(rng2, Sh2.Cells(Aa(i2), 1)) EndIf Next Next IfNot rng2 IsNothingThen
rng2.EntireRow.Delete EndIf
Я пока не смог бы с ним совладать)). С двумя схожими кодами проще провести аналогии и выяснить суть. Восхитительно работает код. Только что его испробовал и начал разбирать. Спасибо.timo64uk