Question

我知道标题可能会让人感到困惑，但这是我最好的方法。

为了提供进一步的解释，我有一本书和两张纸：

表A在第1行中包含人名（A1，B1，C1等）。名称的数量会更改，有时更多，有时更少。
表B在A列中包含人名列表，在B列中包含值。例如：
```
A       B
John    22
John    13
Sam     90
```

我需要一个宏，该宏查看工作表A中每一列的第一行中的值，然后返回，将所有匹配的值从工作表B中的列表粘贴到工作表A中的第二行。

它看起来像：

表A：
```
A        B
John     Sam
22       90
13
```

我没有时间测试任何东西，但我想我可以在B1：B [X]中粘贴一个公式，该公式查找名称在列表中出现的次数并找到其名称起始位置并将其用于复制并粘贴B列中的相应范围。

我不是Macro Pro，但这就是我现在的想法。如果有人能理解这种枯燥的解释并能提供帮助，那就太好了！

Answer 1

我认为最简单的方法是使用集合/字典。我假设您在工作表A中的所有姓名都是唯一的。

Option Explicit

Sub RetrieveData()

Dim wb As Workbook
Dim ws_A As Worksheet
Dim ws_B As Worksheet

Dim HeaderRow As Long
Dim HeaderLastColumn As Long
Dim TableColStart As Long
Dim NameList As Object
Dim i As Long

Dim ws_B_lastrow As Long
Dim NextEntryline As Long
Dim NameCol As Long

Set wb = ActiveWorkbook
Set ws_A = wb.Worksheets("Sheet A")
Set ws_B = wb.Worksheets("Sheet B")
Set NameList = CreateObject("Scripting.Dictionary")

With ws_A
    HeaderRow = 1  'set the header row in sheet A
    TableColStart = 1 'Set start col in sheet A
    HeaderLastColumn = .Cells(HeaderRow, Columns.Count).End(xlToLeft).Column  'Get number of NAMEs you have

    For i = TableColStart To HeaderLastColumn
        If Not NameList.Exists(UCase(.Cells(HeaderRow, i).Value)) Then  'check if the name exists in the dictionary
             NameList.Add UCase(.Cells(HeaderRow, i).Value), i 'if does not exist record name as KEY and Column number as value in dictionary
        End If
    next i

End With




With ws_B
    ws_B_lastrow = .Cells(Rows.Count, 1).End(xlUp).Row  ' Get number of DATA you have in sheet B
    For i = 1 To ws_B_lastrow   'for each data
        NameCol = NameList(UCase(.Cells(i, 1).Value))  'get the column where the name is in Sheet A from the dictionaary
        If NameCol <> 0 Then  'if 0 means the name doesnt exists
            NextEntryline = ws_A.Cells(Rows.Count, NameCol).End(xlUp).Row + 1 'get the next entry line of the particular name in sheet A
            ws_A.Cells(NextEntryline, NameCol).Value = .Cells(i, 2) 'insert the data
        End If

    Next i
End With


End Sub

Answer 2

我的理解方式：诸如时间卡报告生成器，或Sheet2中的名称和值的任意列表，并且您希望以类似数据透视表的合并方式将Sheet2转置并合并到Sheet1（确保您不能使用枢轴？）。

纯VBA明智的做法是，几年前我做了类似的事情（我的用例是上述的时间表报告）：

按名称列对Sheet2进行排序。
使用lastrow = Range("A" & Rows.Count).End(xlUp).row计算最后一行。
还初始化行漫游器（RCTR）和列计数器（CCTR），它们将在写入输出表时进行迭代或重置。
从头开始，遍历整个经过排序的原始列表，称为Sheet2（For n = 1 To lastrow ... Next n）。
对于每一行，将Range("A" & n)与Range("A" & n-1)进行比较，以确定何时出现新名称（您将覆盖此测试，并仅假设第1行使用新名称）。
如果在第4步中出现新名称，请将RCTR重置为2，然后将CCTR设置为1，然后将该新名称复制到Worksheets("Sheet1").Cells(1,CCTR)（列是当前列计数器，行是1）。
将数值复制到Worksheets("Sheet1").Cells(RCTR,CCTR)中，然后迭代RCTR。
转到步骤5。

由于对工作表进行了排序，因此我们只关心Sheet2中的名称列何时更改，因此几乎可以忽略它在给定数据集中出现了多少次。

Answer 3

我建议遍历工作表B中的所有数据，将它们与工作表A中的第一行匹配，如果匹配，则将值写入匹配列中的下一个空闲行。

Option Explicit

Public Sub SortDataIntoSheetA()
    Dim wsSrc As Worksheet
    Set wsSrc = ThisWorkbook.Worksheets("Sheet B") 'define source worksheet

    Dim wsDest As Worksheet
    Set wsDest = ThisWorkbook.Worksheets("Sheet A") 'define destination worksheet

    Dim LastSrcRow As Long
    LastSrcRow = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row 'find last used row in source

    Dim DestCol As Long, LastDestRow As Long

    Dim iRow As Long
    For iRow = 1 To LastSrcRow 'loop throug all rows in source
        DestCol = 0 'initialize
        On Error Resume Next 'if next row throws error hide it
        DestCol = WorksheetFunction.Match(wsSrc.Cells(iRow, "A").Value, wsDest.Rows(1), 0) 'find correct column
        On Error GoTo 0 're-enable error reporting!!

        'if nothing matched DestCol will still be 0

        If DestCol > 0 Then
            LastDestRow = wsDest.Cells(wsDest.Rows.Count, DestCol).End(xlUp).Row 'find last used row in destination column
            wsDest.Cells(LastDestRow + 1, DestCol).Value = wsSrc.Cells(iRow, "B").Value 'write value
        End If
    Next iRow
End Sub

Excel宏，返回用于查找范围的所有值

3 个答案: