Question

我发现很难将这个问题写成一个简洁的问题，所以我会尽力在这里解释一下。

我在Excel中有一个大型列表，如下所示:(原始列表）

1
Term1
Term4
Term6
2
Term1
3
Term2
Term3
Term5
4
Term1
Term2
Term3
Term5

现在，我已经编写了一系列脚本来将此列表转换为另一种形式，如下所示:(成品）

Term 1: 1 2 4
Term 2: 3 4 
Term 3: 3 4 
Term 4: 1
Term 5: 3 4

但是，我觉得我的脚本效率很低。首先，它删除了原始列表中出现的所有条款，将它们与成品A列对齐。

然后，它重新排列原始列表，以便＆＃39;标题＆＃39; （1,2,3,4 ......）都出现在顶行，基本上是水平而不是垂直。我将此称为“图书馆”。

最后，它包含一个循环说＆＃34;在图书馆中出现Term1的任何地方，复制该列第1行中出现的任何内容＆＃34; （这将是1,2和4）。

然而，有没有更有效的方法来做到这一点，这并不涉及制作图书馆＆＃39;？我可以写一些通过原始列表的内容并说出＆＃34;无论在哪里＆＃39; Term1＆＃39;出现，拉出它上面出现的第一个数字，＆＃34;等等。

如果我在解释方面做得不好，请道歉。任何建议或起点都将非常感谢。

编辑：当前脚本，对于那些感兴趣的人。表＆＃34;列表＆＃34;包含成品中的术语列表。而Sheet＆＃34; Library＆＃34;包含水平重新排列的原始列表。

Sub ListLibraryCompare()

    Sheets("List").Select
    Cells.Select
    Selection.ClearContents
    Sheets("Comparison").Select
    Columns("D:D").Select
    Selection.Copy
    Sheets("List").Select
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight

Dim Rng As Range
Dim Keyword As Range
Dim Chunk As Range
Dim Library As Worksheet
Dim List As Worksheet
Dim Bottom As Range
Dim i As Long
Dim X As Long

Application.ScreenUpdating = False

i = 1
X = 0

Set Library = Sheets("Library")
Set List = Sheets("List")

While i <= 7000
Set Keyword = List.Range("A" & i)
Set Bottom = Library.Range("A200").Offset(0, X)
Set Rng = Library.Range("A1").Offset(0, X)
Set Chunk = Library.Range(Rng, Bottom) 'Sets Chunk to the range between cells     Rng and Bottom

If IsEmpty(Rng.Value) = True Then
i = i + 1
X = 0
ElseIf Application.WorksheetFunction.CountIf(Chunk, Keyword) = 0 Then 
X = X + 1
ElseIf Application.WorksheetFunction.CountIf(Chunk, Keyword) >= 1 Then '
Rng.Copy
Keyword.Offset(0, 1).Insert Shift:=xlToRight
X = X + 1
End If
Wend 

End Sub

Answer 1

我发现使用变量数组和用户定义的对象更容易设置和维护，而且速度更快。使用类模块，我们将定义一个对象，我将其命名为cTerm，包含每个Term，以及适用于Headers的{{1}}的集合。。然后创建这些对象的集合，并以您希望的方式输出它。

以下是代码，希望能够很好地注释，以便能够使其适应您的真实数据。可能困难的部分是确定条目是否为Term。我选择使用Header函数来确定。但这可能需要根据您的实际数据的性质进行更改。

请务必重命名课程模块： IsNumeric

班级单元

cTerm

常规模块

Option Explicit

'RENAME this module  cTerm

Private pTerm As String
Private pHeader As String
Private pHeaders As Collection

Private Sub Class_Initialize()
    Set pHeaders = New Collection
End Sub

Public Property Get Term() As String
    Term = pTerm
End Property
Public Property Let Term(Value As String)
    pTerm = Value
End Property

Public Property Get Header() As String
    Header = pHeader
End Property
Public Property Let Header(Value As String)
    pHeader = Value
End Property

Public Function ADDHeader(Value As String)
    On Error Resume Next 'ignore duplicate headers
        pHeaders.Add Value, CStr(Value)
    On Error GoTo 0
End Function

Public Property Get Headers() As Collection
    Set Headers = pHeaders
End Property

循环遍历VBA中的长列表并在下行途中拉取数据

1 个答案:

班级单元

常规模块