vba 根据标准选择单元格，然后复制和粘贴特殊（转置） - 宏帮助
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/5981197/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Selecting Cells Based on Criteria, then Copy and Paste Special (Transpose) - Macro Help
提问by Neil
I was wondering if anyone could help me with the following problem. I have two excel workbooks. Workbook A contains bill data running from 1 to 1000. Each bill is on a different line in numerical order. Workbook B contains bill sponsor information. However, it is formatted as 1 sponsor per line, so 1 bill can occupy multiple rows. Also, the bill number is in column A, while the sponsor name is in column B. So, you have to select the names from column B based on the values from column A.
我想知道是否有人可以帮助我解决以下问题。我有两本excel工作簿。工作簿 A 包含从 1 到 1000 的账单数据。每张账单按数字顺序位于不同的行上。工作簿 B 包含账单发起人信息。但是，它的格式为每行 1 个赞助商，因此 1 张账单可以占用多行。此外，帐单编号在 A 列中，而赞助商名称在 B 列中。因此，您必须根据 A 列中的值从 B 列中选择名称。
I would like to select the names of each sponsor for each bill from workbook B and paste special (transpose) them into workbook A for each bill. I can do this by hand, but it will take a very long time. Is there anyway to automate it? Thank you in advance.
我想从工作簿 B 中为每个法案选择每个发起人的姓名，并将特殊（转置）它们粘贴到每个法案的工作簿 A 中。我可以手动完成此操作，但需要很长时间。反正有自动化吗？先感谢您。
The data look like this
数据看起来像这样
Workbook A
Column A
1
2
3
4
5
工作簿 A
列 A
1
2
3
4
5
Workbook B
Column A Column B
1 Name ID
1 Name ID
2 Name ID
2 Name ID
2 Name ID
2 Name ID
工作簿 B
列 A 列 B
1 姓名 ID
1 姓名 ID
2 姓名 ID
2 姓名 ID
2 姓名 ID
2 姓名 ID
回答by Excellll
A possible solution is to use a user-defined formula, that when used as array formula, will return a comma-separated list of bill sponsors for each bill id. I posted the code for the UDF previously here. Once you have entered the code in a VBA module, enter the following formula in B2 in Workbook A:
一个可能的解决方案是使用用户定义的公式，当用作数组公式时，将为每个帐单 ID 返回一个以逗号分隔的帐单发起人列表。我之前在这里发布了 UDF 的代码。在 VBA 模块中输入代码后，在工作簿 A 的 B2 中输入以下公式：
=CCARRAY(IF(A2=[Workbook_B]Sheet_Name!$A:$A00,[Book2]Sheet_Name!$B:$B00),", ")
Press Ctrl+Shift+Enter to enter the formula as an array formula. Then fill-down for all Bill IDs.
按 Ctrl+Shift+Enter 将公式作为数组公式输入。然后填写所有账单 ID。
Just to be clear, you'll need to insert the appropriate file and sheet names and adjust the number of rows to match your data. Also, since array formulas can be kind of computationally clunky, you'll probably want to copy column B and paste special 'Values only' back to column B.
为了清楚起见，您需要插入适当的文件和工作表名称并调整行数以匹配您的数据。此外，由于数组公式在计算上可能有点笨拙，您可能希望复制 B 列并将特殊的“仅值”粘贴回 B 列。
回答by Tim Williams
Untested...
未经测试...
Sub Tester()
Dim Bills As Excel.Worksheet
Dim Sponsors As Excel.Worksheet
Dim c As Range, f As Range
Set Bills = Workbooks("WorkbookA").Sheets("Bills")
Set Sponsors = Workbooks("WorkbookB").Sheets("Sponsors")
Set c = Sponsors.Range("A2")
Do While c.Value <> ""
Set f = Bills.Range("A:A").Find(c.Value, , xlValues, xlWhole)
If Not f Is Nothing Then
Bills.Cells(f.Row, Bills.Columns.Count).End(xlToLeft).Offset(0, 1).Value = c.Offset(0, 1).Value
Else
c.Font.Color = vbRed
End If
Set c = c.Offset(1, 0)
Loop
End Sub
回答by chris neilsen
Here's a macro that will do the trick.
这是一个可以解决问题的宏。
It does the work in memory variant arrays to provide resonable speed. Looping over the cells/rows would produce simpler code, but would run much slower.
它在内存变体数组中工作以提供合理的速度。循环遍历单元格/行会产生更简单的代码，但运行速度会慢得多。
It requires (and tests for) that all the BillIDs are present in the sponsor list
它要求（并测试）所有 BillID 都出现在赞助商列表中
Also, it uses , to seperate the sponsors list, so , must not be in any of the sponsor names. If it is choose a different character .
此外，它使用 , 来分隔赞助商列表，因此 , 不得出现在任何赞助商名称中。如果是选择不同的字符。
Sub GetSponsors()
Dim rngSponsors As Range, rngBills As Range
Dim vSrc As Variant
Dim vDst() As Variant
Dim i As Long, j As Long
' Assumes data starts at cell A2 and extends down with no empty cells
Set rngSponsors = Sheets("Sponsors").[A2]
Set rngSponsors = Range(rngSponsors, rngSponsors.End(xlDown))
' Count unique values in column A
j = Application.Evaluate("SUM(IF(FREQUENCY(" _
& rngSponsors.Address & "," & rngSponsors.Address & ")>0,1))")
ReDim vDst(1 To j, 1 To 2)
j = 1
' Get original data into an array
vSrc = rngSponsors.Resize(, 2)
' Create new array, one row for each unique value in column A
vDst(1, 1) = vSrc(1, 1)
vDst(1, 2) = "'" & vSrc(1, 2)
For i = 2 To UBound(vSrc, 1)
If vSrc(i - 1, 1) = vSrc(i, 1) Then
vDst(j, 2) = vDst(j, 2) & "," & vSrc(i, 2)
Else
j = j + 1
vDst(j, 1) = vSrc(i, 1)
vDst(j, 2) = "'" & vSrc(i, 2)
End If
Next
Set rngBills = Sheets("Bills").[A2]
Set rngBills = Range(rngBills, rngBills.End(xlDown))
' check if either list has missing Bill numbers
If UBound(vDst, 1) = rngBills.Rows.Count Then
' Put new data in sheet
rngBills.Resize(, 2) = vDst
rngBills.Columns(2).TextToColumns , _
Destination:=rngBills.Cells(1, 2), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=False, _
Semicolon:=False, _
Comma:=True, _
Space:=False, _
Other:=False
ElseIf UBound(vDst, 1) < rngBills.Rows.Count Then
MsgBox "Missing Bills in Sponsors list"
Else
MsgBox "Missing Bills in Bills list"
End If
End Sub
