我有一個從 A2 到 E45000 的資料集，其中包含有關公司的資料。一些用戶有多個供應商 ID。
我在 extendoffice 上玩過 This guide，但可惜無法讓它按照我想要的方式作業。我不斷收到腳本錯誤、超出范圍錯誤等。
我的目標是連接具有多個供應商 ID 的用戶的值，如 F 列所示。John Smith 有 12345 和 12348。值得注意的是，電子郵件不會改變（他們可能在所有上面輸入了一些大小寫或類似 JOHNSMITH@company 或 johnsmith@company），但電子郵件本身將是完全相同的系列。
如何在 Excel 中使用 VBA 或僅使用普通 excel 來實作這一點？
uj5u.com熱心網友回復：
嘗試：
=TEXTJOIN(", ", TRUE, FILTER($A$2:$A$5, $E2=$E$2:$E$5))
uj5u.com熱心網友回復：
連接唯一
- 的范圍內的作業表（的
sName），在一列中“洗掉重復”（事實并非如此）uCol，并在同一時間串接另一列的值cCol在另一個作業表，并回傳結果（dName）
Option Explicit
Sub UniqueConcatenate()
' Source
Const sName As String = "Sheet1"
Const sCols As String = "A:E"
' Destination
Const dName As String = "Sheet2"
Const dfCellAddress As String = "A1"
Const dDelimiter As String = ", "
' Both
Const cCol As Long = 1
Const uCol As Long = 5
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion.Columns(sCols)
Dim sData As Variant: sData = srg.Value
Dim srCount As Long: srCount = srg.Rows.Count
Dim cCount As Long: cCount = srg.Columns.Count
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim dr As Long: dr = 1 ' skip headers
Dim uKey As Variant
Dim sr As Long
Dim cr As Long
Dim c As Long
For sr = 2 To srCount ' skip headers
uKey = sData(sr, uCol)
If Not IsError(uKey) Then
If Len(uKey) > 0 Then
If dict.Exists(uKey) Then
cr = dict(uKey)
sData(cr, cCol) = sData(cr, cCol) _
& dDelimiter & CStr(sData(sr, cCol))
Else
dr = dr 1
dict(uKey) = dr
sData(dr, cCol) = CStr(sData(sr, cCol))
For c = 1 To cCount
If c <> cCol Then
sData(dr, c) = sData(sr, c)
End If
Next c
End If
End If
End If
Next sr
Dim dws As Worksheet: Set dws = wb.Worksheets(dName) ' worksheet, range
Dim drg As Range: Set drg = dws.Range(dfCellAddress).Resize(dr, cCount)
Dim dcdrg As Range ' format as text
Set dcdrg = drg.Columns(cCol).Resize(dr - 1).Offset(1)
dcdrg.NumberFormat = "@"
drg.Value = sData ' write result
Dim dclrrg As Range ' clear below
Set dclrrg = drg.Resize(dws.Rows.Count - drg.Row - dr 1).Offset(dr)
dclrrg.Clear
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/qita/409009.html
標籤：
上一篇：VBA復制/粘貼跳過每5行
下一篇：無法在vba中格式化圖表