我知道标题可能看起来令人困惑,但这是我能做的最好的方式。
为了进一步解释,我有一个工作簿和两个表:
A B
John 22
John 13
Sam 90
我需要的是一个宏,它查看工作表A中每列的第一行中的值,并返回将工作表B中列表中的所有匹配值粘贴到工作表A中的第二行。
它看起来像:
A B
John Sam
22 90
13
我没有时间测试任何东西,但我想我可以在B1:B [X]中粘贴一个公式,查找名称出现在列表中的次数并找到它的起始位置和用它来复制和粘贴B列中的相应范围。
我不是一个宏观专业人士,但这是我现在的想法。如果有人能够理解那个干燥的解释并且可以帮助那将是惊人的!
我认为最简单的方法是使用集合/字典。我假设你在表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
我理解的方式:类似于时间卡报告生成器,或Sheet2中的任意名称和值列表,并且您希望将Sheet2转置并合并到Sheet1中的数据透视表中进行整合(确保您不能只使用数据透视表) ?)。
纯粹的VBA方面我几年前做过这样的事情(我的用例是上面提到的时间卡报告):
lastrow = Range("A" & Rows.Count).End(xlUp).row
计算最后一行。For n = 1 To lastrow ... Next n
)的整个分类原始列表开始for-next。Range("A" & n)
与Range("A" & n-1)
进行比较,以确定何时出现新名称(您将覆盖此测试,并为行1假设一个新名称)。Worksheets("Sheet1").Cells(1,CCTR)
(列是当前列计数器,行为1)。Worksheets("Sheet1").Cells(RCTR,CCTR)
,然后迭代RCTR。由于工作表已排序,我们只关心Sheet2中的名称列何时更改,因此几乎可以忽略它在给定数据集中出现的次数。
我建议遍历Sheet B中的所有数据,将它们与Sheet 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