Консолидация столбцов в Excel

Question

У меня есть две колонки в Excel, как показано ниже:

a, яблоко
a, бананана
a, апельсин
a, слива
b, яблоко
b,ягода
b, апельсин
b, грейпфрут
c, дыня
c, ягода
c, киви

Мне нужно объединить их вот так на другом листе

a, яблоко, бананна, апельсин, слива
b, яблоко, ягода, апельсин, грейпфрут
c, дыня, ягода, киви

Любая помощь будет оценена

Этот код работает, но он слишком медленный.Мне нужно перебрать 300000 записей.

Dim MyVar As String
Dim Col
Dim Var

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

    ' Select first line of data.
  For Var = 1 To 132536
  Sheets("Line Item Detail").Select
  Range("G2").Select
  ' Set search variable value.
  Var2 = "A" & Var

  MyVar = Sheets("Sheet1").Range(Var2).Value

  'Set Do loop to stop at empty cell.
  Col = 1
  Do Until IsEmpty(ActiveCell)
     ' Check active cell for search value.
     If ActiveCell.Value = MyVar Then

        Col = Col + 1
        Sheets("Sheet1").Range(Var2).Offset(0, Col).Value = ActiveCell.Offset(0, 1).Value


     End If
     ' Step down 1 row from present location.
     ActiveCell.Offset(1, 0).Select
  Loop
  Next Var

 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
 Application.EnableEvents = True

Answer 1

Ваш код является хорошей отправной точкой.Соедините вещи, чтобы ускорить его.

Вместо использования ActiveCell и SelectValue просто измените значения непосредственно следующим образом:

Sheet1.Cells(1, 1) = "asdf"

Кроме того, перед началом сортируйте свой лист по первому (ключевому) столбцу.ваши циклы (есть метод сортировки VBA, если вам нужно сделать это программно).Это может занять немного времени, но спасет вас в долгосрочной перспективе.Тогда ваш внутренний цикл Do Пока IsEmpty должен идти только до тех пор, пока значение ключа не изменится, а не будет проходить через весь набор данных каждый раз.Это сокращает ваше время выполнения на порядок.

ОБНОВЛЕНИЕ
Я включил код ниже.Это побежало около минуты для 300K случайных строк данных.Сортировка заняла около 3 секунд.(У меня обычный рабочий стол - примерно 3 года).

Сортировка в VBA следующим образом Sheet1.Range("A1:B300000").Sort key1:=Sheet1.Range("A1").Вы также можете заменить параметр Range двумя параметрами Cell (примеры см. В справке Excel).

Код для обработки.Возможно, вы захотите параметризовать лист - для краткости я просто закодировал его.

    Dim LastKey As String
    Dim OutColPtr As Integer
    Dim OutRowPtr As Long
    Dim InRowPtr As Long
    Dim CurKey As String

    Const KEYCOL As Integer = 1         'which col holds your "keys"
    Const VALCOL As Integer = 2         'which col holds your "values"
    Const OUTCOLSTART As Integer = 4    'starting column for output

    OutRowPtr = 0   'one less than the row you want your output to start on
    LastKey = ""
    InRowPtr = 1    'starting row for processing

    Do
        CurKey = Sheet2.Cells(InRowPtr, KEYCOL)
        If CurKey <> LastKey Then
            OutRowPtr = OutRowPtr + 1
            LastKey = CurKey
            Sheet2.Cells(OutRowPtr, OUTCOLSTART) = CurKey
            OutColPtr = OUTCOLSTART + 1
        End If

        Sheet2.Cells(OutRowPtr, OutColPtr) = Sheet2.Cells(InRowPtr, VALCOL)
        OutColPtr = OutColPtr + 1
        InRowPtr = InRowPtr + 1

    Loop While Sheet2.Cells(InRowPtr, KEYCOL) <> ""

Answer 2

Не могли бы вы дать этому шанс?

ThisWorkbook.Sheets("Sheet1").Cells.ClearContents
intKeyCount = 0
i = 1

' loop till we hit a blank cell
Do While ThisWorkbook.Sheets("Line Item Detail").Cells(i, 1).Value <> ""
    strKey = ThisWorkbook.Sheets("Line Item Detail").Cells(i, 1).Value

    ' search the result sheet
    With ThisWorkbook.Worksheets("Sheet1")
    For j = 1 To intKeyCount

        ' we're done if we hit the key
        If .Cells(j, 1).Value = strKey Then
            .Cells(j, 2).Value = .Cells(j, 2).Value + 1
            .Cells(j, .Cells(j, 2).Value).Value = ThisWorkbook.Sheets("Line Item Detail").Cells(i, 2).Value
            Exit For
        End If
    Next

    ' new key
    If j > intKeyCount Then
        intKeyCount = intKeyCount + 1
        .Cells(j, 1).Value = strKey
        .Cells(j, 3).Value = ThisWorkbook.Sheets("Line Item Detail").Cells(i, 2).Value
        ' keep track of which till which column we filled for the row
        .Cells(j, 2).Value = 3
    End If
    End With

    i = i + 1
Loop

' delete the column we used to keep track of the number of values
ThisWorkbook.Worksheets("Sheet1").Columns(2).Delete

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

Answer 3

Это можно сделать вручную менее чем за 1 минуту, используя сводную таблицу и группировку.

• создать круг с фруктами в виде полей строк (крайний левый столбец)
• переместите и перетащите фрукты, которые вы хотите сгруппировать, рядом друг с другом
• для группировки, выделите ячейки в крайнем левом столбце и выберите Группировать из меню сводной таблицы
• повторить предыдущую точку для каждой группы

Теперь, когда вы можете сделать это эффективным способом «вручную», запишите его и переписайте правильно, и вы можете получить эффективный код, используя возможности его среды (Excel).

Answer 4

Существует подход, основанный на сводных таблицах, который вы можете рассмотреть.

Создайте сводную таблицу (если в Excel 2007 используется «классический» формат) с обоими полями в области «Метки строк». Удалите промежуточные итоги и итоги. Это даст вам уникальный список всех значений для каждой из категорий. Затем вы можете скопировать и вставить значения, чтобы получить данные в следующем формате:

a   apple
    bannana
    orange
    plum
b   apple
    berry
    grapefruit
    orange
c   berry
    kiwi
    melon

Все ваши уникальные значения теперь отображаются компактно, и вы можете использовать VBA для циклического прохождения этого небольшого подмножества данных.

Если вам нужна помощь с VBA для создания сводной таблицы, сообщите мне.

Answer 5

Извините, я не могу быть более полезным, у меня нет под рукой Excel.

Вот связанная тема по VBA:

http://www.mrexcel.com/forum/showthread.php?t=459716

И фрагмент из этой темы:

Function MultiVLookup(rngLookupValues As Range, strValueDelimiter As String, rngLookupRange As Range, TargetColumn As Integer) As String
Dim varSplitValues As Variant, varItem As Variant, strResult As String, i As Integer, varLookupResult As Variant

varSplitValues = Split(rngLookupValues, strValueDelimiter, -1, vbTextCompare)

For Each varItem In varSplitValues

    On Error Resume Next
    varLookupResult = Application.WorksheetFunction.VLookup(varItem, rngLookupRange, TargetColumn, False)

    If Err.Number <> 0 Then
        strResult = strResult & "#CompanyNameNotFound#"
        Err.Clear
    Else
        strResult = strResult & varLookupResult
    End If
    On Error GoTo 0

    If UBound(varSplitValues) <> i Then
        strResult = strResult & ", "
    End If
    i = i + 1
Next varItem

MultiVLookup = strResult

End Function