Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Создания диапазона путем интеграции одного диапазона в другой
 
Здравствуйте гуру экселя. Опять не хватает знаний. В общем пытаюсь написать макрос для создания диапазона из двух столбцов. В одном столбце значения ячеек повторяющиеся, во втором нет, А третий, который делаю, должен состоять из уникальных значений первого с интеграцией всех значений второго. В приложенном файле все понятно с первого взгляда.
Вроде как понимаю что нужно скопировать первый столбец, удалить дубликаты. Потом впр'ом найти ячейки второго столбца и вставить их между строк в создаваемый столбец. Как это в vba написать ума не хватает.
 
Макрос
 
Хорошее решение Karataev'a ... а у меня с "петельками" ... :-)
Код
Option Explicit

Sub stolbik_zaychik()
Dim r As Long, rw As Long, rww As Long, rws As Long

    r = 5: rww = 5: rws = Cells(Rows.Count, "b").End(xlUp).Row
    Do While r <= rws
        Do Until Trim(Cells(r, 2).Value) = ""
            rw = r
            Do While Cells(r, 2).Value = Cells(r + 1, 2).Value
                r = r + 1
            Loop
            Cells(rww, 7).Value = Cells(rw, 2).Value
            Cells(rww + 1, 7).Resize((r - rw + 1), 1).Value = Cells(rw, 3).Resize((r - rw + 1), 1).Value
            If (r - rw + 1) > 1 Then rww = (rww + 1) + (r - rw + 1) Else rww = (rww + 2)
            r = r + 1
        Loop
        r = r + 1
    Loop
End Sub
 
А у меня вообще без "петелек"  :)
Код
Sub Ba()
Dim n&
  n = Cells(Rows.Count, "C").End(xlUp).Row
  With Range("E5").Resize((n - 4) * 2)
    .Formula = Replace( _
      "=IF(INDEX($B$5:$C$#,(ROW(A1)-1)/2+1,2-ISODD(ROW(A1)))="""","""",INDEX($B$5:$C$#,(ROW(A1)-1)/2+1,2-ISODD(ROW(A1))))" _
      , "#", n)
    .Value = .Value
    On Error Resume Next
    .SpecialCells(xlCellTypeBlanks).Delete xlUp
    .RemoveDuplicates Columns:=1, Header:=xlNo
  End With
End Sub
 
еще вариант)

Код
Sub unite()
    Dim o_dict As Object
    Set o_dict = CreateObject("Scripting.dictionary")
    Dim arr_in
    arr_in = Range("B5:C12").Value
    For i = LBound(arr_in) To UBound(arr_in)
        For n = LBound(arr_in, 2) To UBound(arr_in, 2)
            If arr_in(i, n) <> "" Then a = o_dict(arr_in(i, n))
        Next n
    Next i
    arr_out = o_dict.keys
    Range("E5").Resize(UBound(arr_out) + 1).Value = Application.Transpose(arr_out)
End Sub
 
Всем огромное спасибо. Знание - сила!
Страницы: 1
Читают тему (гостей: 1)