[英]Selecting Cells Based on Criteria, then Copy and Paste Special (Transpose) - Macro Help
我想知道是否有人可以幫助我解決以下問題。 我有兩本excel工作簿。 工作簿 A 包含從 1 到 1000 的賬單數據。每張賬單按數字順序位於不同的行上。 工作簿 B 包含賬單發起人信息。 但是,它的格式為每行 1 個贊助商,因此 1 張帳單可以占用多行。 此外,帳單編號在 A 列中,而贊助商名稱在 B 列中。因此,您必須根據 A 列中的值從 B 列中選擇名稱。
我想從工作簿 B 中為每個法案選擇每個發起人的姓名,並將特殊(轉置)它們粘貼到每個法案的工作簿 A 中。 我可以手動完成此操作,但需要很長時間。 反正有自動化嗎? 先感謝您。
數據看起來像這樣
工作簿 A
A欄
1
2
3
4
5
工作簿 B
A列 B列
1 姓名 ID
1 姓名 ID
2 姓名標識
2 姓名標識
2 姓名標識
2 姓名標識
一個可能的解決方案是使用用戶定義的公式,當用作數組公式時,將為每個帳單 ID 返回一個以逗號分隔的帳單發起人列表。 我之前在這里發布了 UDF 的代碼。 在 VBA 模塊中輸入代碼后,在工作簿 A 的 B2 中輸入以下公式:
=CCARRAY(IF(A2=[Workbook_B]Sheet_Name!$A$2:$A$2000,[Book2]Sheet_Name!$B$2:$B$2000),", ")
按 Ctrl+Shift+Enter 將公式作為數組公式輸入。 然后填寫所有賬單 ID。
為了清楚起見,您需要插入適當的文件和工作表名稱並調整行數以匹配您的數據。 此外,由於數組公式在計算上可能有點笨拙,您可能希望復制 B 列並將特殊的“僅值”粘貼回 B 列。
未經測試...
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
這是一個可以解決問題的宏。
它在內存變體數組中工作以提供合理的速度。 循環遍歷單元格/行會產生更簡單的代碼,但運行速度會慢得多。
它要求(並測試)所有 BillID 都出現在贊助商列表中
此外,它使用 , 來分隔贊助商列表,因此 , 不得出現在任何贊助商名稱中。 如果是選擇不同的字符。
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
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.