Question

我在excel中有两列，如下所示

一个，苹果
一，bannana
一，橙色
一，梅花
B，苹果
B，浆果
B，橙色
B，柚子
C，瓜
C，浆果
c，奇异果

我需要在不同的表单上将它们整合在一起

一个，苹果，bannana，橙，李子
B，苹果，浆果，柑橘，柚子
c，甜瓜，浆果，猕猴桃

任何帮助将不胜感激

此代码有效，但速度太慢。我必须循环300,000个条目。

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 Until IsEmpty内循环只需要每次都改变键的值而不是整个数据集。这会将您的运行时间缩短一个数量级。

<强>更新
我在下面提供了一些代码。它在大约一分钟内运行300K随机数据线。排序大约需要3秒钟。（我有一个普通的桌面 - 大约3岁）。

按如下方式在VBA中排序Sheet1.Range("A1:B300000").Sort key1:=Sheet1.Range("A1")。您还可以使用两个Cell参数替换Range参数（有关示例，请参阅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

抱歉，我没有更多的帮助，我没有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

Answer 4

您可能需要考虑基于数据透视表的方法。

使用“行标签”区域中的两个字段创建数据透视表（如果使用Excel 2007，请使用“经典”格式）。删除小计和总计。这将为您提供每个类别的所有值的唯一列表。然后，您可以复制并粘贴值以获取此格式的数据：

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

现在，您可以紧凑地显示所有唯一值，并且可以使用VBA循环遍历此较小的数据子集。

如果您需要有关VBA的任何帮助来创建数据透视表，请告诉我。

Answer 5

这可以使用数据透视表和分组在不到1分钟的时间内完成。

使用水果作为行字段（最左边的列）
将想要分组的水果拖动到彼此旁边
分组，选择最左侧列中的单元格，然后从数据透视表菜单中选择组
重复每个组的上一个点

既然您可以“手动”高效地进行操作，记录并正确地重写它，并且您可能会使用其环境（Excel）的设施来获得高效的代码。

在Excel中合并列

5 个答案: