1

我在 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
4

5 回答 5

2

您的代码是一个很好的起点。结合一些事情来加快速度。

而不是使用 ActiveCell 和 SelectValue 只需像这样直接更改值： 

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

此外，在开始循环之前，在第一列（键）上对工作表进行排序（如果您需要以编程方式执行此操作，可以使用 VBA 排序方法）。这可能需要一点时间，但从长远来看会为您节省时间。然后你的 Do Until 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) <> ""
于 2010-06-10T13:10:03.470 回答
1

你能试一试吗？

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
于 2010-06-10T07:14:03.787 回答
0

抱歉，我帮不上忙，我手头没有 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
于 2010-06-09T23:14:20.207 回答
0

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

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

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

您的所有唯一值现在都紧凑地显示，您可以使用 VBA 循环通过这个较小的数据子集。

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

于 2010-06-10T08:45:49.917 回答
0

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

  • 创建一个以水果作为行字段的数据透视表（最左边的列）
  • 移动拖动你想要分组的水果并排在一起
  • 要进行分组，请选择最左侧列中的单元格，然后从数据透视表菜单中选择分组
  • 为每组重复上一点

现在您可以“手动”以有效的方式完成它，记录它并正确重写它，您最终可能会使用其环境（Excel）的设施获得高效的代码。

于 2010-06-10T18:16:56.017 回答