我有一個將列從垂直狀態轉換為水平狀態的代碼（每組在一行中）這是一些虛擬資料
Groups Amount Notes Name
A 10 N1 GroupA
A 20 N2 GroupA
A 30 N3 GroupA
B 40 N4 GroupB
B 50 N5 GroupB
B 60 N6 GroupB
B 70 N7 GroupB
C 80 N8 GroupC
D 90 N9 GroupD
D 100 N10 GroupD
這是僅處理第二列的代碼
Sub Test()
Dim v, a, i As Long
v = Cells(1).CurrentRegion
ReDim b(UBound(v) 1)
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(v)
a = .Item(v(i, 1))
If IsEmpty(a) Then a = b
a(0) = v(i, 1)
a(UBound(a)) = a(UBound(a)) 1
a(a(UBound(a))) = v(i, 2)
.Item(v(i, 1)) = a
Next i
Range("G2").Resize(.Count, UBound(a) - 1) = Application.Index(.Items, 0)
End With
End Sub
該代碼適用于第二列，但我也需要以相同的想法處理第三列。至于第四列將只有一次（在輸出中將在一列中）
這是預期的輸出
uj5u.com熱心網友回復：
您的問題的解決方案比最初看起來要復雜一些。但是感謝您使用字典而不是嘗試通過陣列來做所有事情。
下面的代碼使用了一個字典，它的鍵是 Groups 列中的值。與這些鍵關聯的 Item 是一個 Arraylist。反過來，Arraylist 由 Arraylists 填充，其中包含與 Group Column 中的 Key 對應的每一行的 Amount、Note 和 Nname 值。使用 Arraylist 是因為我們可以輕松地從 An Arraylist 中洗掉專案。
請注意，Scripting.Dictionaries 和 ArrayLists 的 Item 方法是默認方法，因此我沒有在代碼中明確呼叫 Item 方法。如果默認方法不是專案，那么我會特別說明默認方法。
下面的代碼比你原來的帖子要長很多，但我希望你能看到事情是如何被分成邏輯任務的。
您還將看到我大量使用垂直間距來將 codee withing 方法分解為“段落”。這是個人喜好。
Public Sub Test2()
Dim myD As Scripting.Dictionary
Set myD = GetCurrentRegionAsDictionary(Cells(1).CurrentRegion)
Dim myArray As Variant
myArray = GetPopulatedOutputArray(myD)
Dim Destination As Range
Set Destination = Range("A20")
Destination.Resize(UBound(myArray, 1), UBound(myArray, 2)).Value = myArray
End Sub
'@Description("Returns an Array in the desired output format from the contents of the Scripting.Dictionary created from the CurrentRegion")
Public Function GetPopulatedOutputArray(ByRef ipD As Scripting.Dictionary) As Variant
Dim myAmountSpan As Long
myAmountSpan = MaxSubArrayListSize(ipD)
Dim myArray As Variant
ReDim myArray(1 To ipD.Count, 1 To 2 myAmountSpan * 2)
Dim myHeaderText As Variant
myHeaderText = GetHeaderTextArray(ipD, myAmountSpan)
Dim myIndex As Long
For myIndex = 0 To UBound(myHeaderText)
myArray(1, myIndex 1) = myHeaderText(myIndex)
Next
Dim myRow As Long
myRow = 2
Dim myKey As Variant
For Each myKey In ipD
myArray(myRow, 1) = myKey
Dim myCol As Long
myCol = 2
Dim myList As Variant
For Each myList In ipD(myKey)
myArray(myRow, myCol) = myList(0)
myArray(myRow, myCol myAmountSpan) = myList(1)
If VBA.IsEmpty(myArray(myRow, UBound(myArray, 2))) Then
myArray(myRow, UBound(myArray, 2)) = myList(2)
End If
myCol = myCol 1
Next
myRow = myRow 1
Next
GetPopulatedOutputArray = myArray
End Function
'@Description("Returns an array contining the appropriately formatted header text")
Public Function GetHeaderTextArray(ByRef ipD As Scripting.Dictionary, ByVal ipAmountSpan As Long) As Variant
' The Scripting.Dictionary does not maintain order of addition
' so we need to search for a key longer than one character
Dim myFoundKey As String
Dim myHeaderList As ArrayList
Dim myKey As Variant
For Each myKey In ipD
If Len(myKey) > 2 Then
myFoundKey = myKey
Set myHeaderList = ipD(myKey)(0)
Exit For
End If
Next
Dim myT As String
myT = myFoundKey & ","
Dim myIndex As Long
For myIndex = 1 To ipAmountSpan
myT = myT & myHeaderList(0) & CStr(myIndex) & ","
Next
For myIndex = 1 To ipAmountSpan
myT = myT & myHeaderList(1) & CStr(myIndex) & ","
Next
myT = myT & myHeaderList(2)
' removeove the header text as it is no longer needed
ipD.Remove myFoundKey
GetHeaderTextArray = Split(myT, ",")
End Function
'@Description("Returns a Dictionary of arraylists using column 1 of the current region as the key
Public Function GetCurrentRegionAsDictionary(ByRef ipRange As Excel.Range) As Scripting.Dictionary
Dim myArray As Variant
myArray = ipRange.Value
Dim myD As Scripting.Dictionary
Set myD = New Scripting.Dictionary
Dim myRow As Long
For myRow = LBound(myArray, 1) To UBound(myArray, 1)
Dim myList As ArrayList
Set myList = GetRowAsList(myArray, myRow)
Dim myKey As Variant
Assign myKey, myList(0)
myList.RemoveAt 0
If Not myD.Exists(myKey) Then
myD.Add myKey, New ArrayList
End If
' Add an arraylist to the arraylist specified by Key
myD.Item(myKey).Add myList
Next
Set GetCurrentRegionAsDictionary = myD
End Function
'@Description("Get the size of largest subArrayList")
Public Function MaxSubArrayListSize(ByRef ipD As Scripting.Dictionary) As Long
Dim myMax As Long
myMax = 0
Dim myKey As Variant
For Each myKey In ipD
If ipD(myKey).Count > myMax Then
myMax = ipD(myKey).Count
End If
Next
MaxSubArrayListSize = myMax
End Function
'@Description("Returns a row of an Array as an ArrayList")
Public Function GetRowAsList(ByRef ipArray As Variant, ByVal ipRow As Long) As ArrayList
Dim myList As ArrayList
Set myList = New ArrayList
Dim myIndex As Long
For myIndex = LBound(ipArray, 2) To UBound(ipArray, 2)
myList.Add ipArray(ipRow, myIndex)
Next
Set GetRowAsList = myList
End Function
Public Sub Assign(ByRef ipTo As Variant, ByRef ipFrom As Variant)
If VBA.IsObject(ipFrom) Then
Set ipTo = ipFrom
Else
ipTo = ipFrom
End If
End Sub
uj5u.com熱心網友回復：
我做的有點不同：
Sub ColsToRows()
Dim dict As Dictionary
Dim inner As Dictionary
Dim arr() As Variant
Dim arrNotExpand() As Variant
'add headers of columns you don't want to have expanded to array
arrNotExpand = Array("Name")
Dim myRange As Range
'set start of range you want to be converted; vals in first column will be used for keys in main dict
Set myRange = Range("A1").CurrentRegion
Dim Destination As Range
'set start destination range
Set Destination = Range("G1")
'creating main dict
Set dict = New Dictionary
'looping through all cells in first column (ex header)
For x = 2 To myRange.Rows.Count
'define key
dictKey = Cells(x, 1).Value
'check if key exists
If dict.Exists(dictKey) Then
'if exists, get innerKey, add val from each col to its inner dict
For y = 2 To myRange.Columns.Count
innerKey = Cells(1, y).Value
newVal = Cells(x, y).Value
'getting array from key, adding val to it, and reassigning updated array
arr = dict(dictKey)(innerKey)
ReDim Preserve arr(UBound(arr) 1)
arr(UBound(arr)) = newVal
dict(dictKey)(innerKey) = arr
Next y
Else
'key does not exist, create new inner dict
Set inner = New Dictionary
'add inner dict for each col, and assign first vals
For y = 2 To myRange.Columns.Count
innerKey = Cells(1, y).Value
newVal = Cells(x, y).Value
arr = Array(newVal)
inner.Add innerKey, arr
Next y
'add inner dict to main dict
dict.Add dictKey, inner
End If
Next x
'establish maxCols, i.e. the max length of any array for inner
maxCols = 1
'since we're retrieving the expanded version of arr for each inner, we can just check the first to get the maxCols val
For Each dictKey In dict.Keys
'checking lengthArray
lengthArray = UBound(dict(dictKey)(dict(dictKey).Keys()(1))) 1
'if it is larger than prev stored val, use new length
If lengthArray > maxCols Then
maxCols = lengthArray
End If
Next dictKey
'convert dict to Destination
'header for keys main dict
Destination = myRange.Cells(1, 1)
'keep track of offset rows
countRow = 0
For Each dictKey In dict.Keys
'keep trach of offset cols
countCol = 0
For Each innerKey In dict(dictKey)
'if so, add the dictKey
If countCol = 0 Then
Destination.Offset(1 countRow, 0) = dictKey
End If
'if innerKey not in arrNotExpand, we want use full array
If IsError(Application.Match(innerKey, arrNotExpand, 0)) Then
'if we are looking at the first key, also add the headers for each inner dict key
If countRow = 0 Then
For col = 1 To maxCols
'add increment for headers, e.g. "Amount1", "Amount2" etc. (replace necessary for getting rid of whitespace)
Destination.Offset(countRow, 1 countCol col - 1) = Replace(innerKey Str(col), " ", "")
Next col
End If
'get length of arr for specific inner dict
lengthArray = UBound(dict(dictKey)(innerKey)) 1
'use here for resizing and fill with array
Destination.Offset(1 countRow, 1 countCol).Resize(1, lengthArray) = dict(dictKey)(innerKey)
'adjust offset cols
countCol = countCol maxCols
Else
'only True if the first innerKey is in arrNotExpand
If countRow = 0 Then
Destination.Offset(countRow, 1 countCol) = innerKey
End If
'no expansion, so use only first val from array
Destination.Offset(1 countRow, 1 countCol) = dict(dictKey)(innerKey)(0)
'adjust offset col just by one
countCol = countCol 1
End If
Next innerKey
'adjust offset row for next dict key
countRow = countRow 1
Next dictKey
End Sub
確保為Set myRange = Range("A1").CurrentRegion和輸入正確的參考Set Destination = Range("F1")。將您不想擴展的列的標題添加到此陣列：arrNotExpand = Array("Name")。照原樣，您將獲得預期的輸出。假設您也添加了“金額”，所以：arrNotExpand = Array("Amount", "Name")，那么您將得到：
如果您向該范圍添加更多列，則此方法有效。只需確保所有標題都是唯一的（否則分配新的 dict.keys 會出錯）。讓我知道是否有任何不清楚的地方，或者如果您發現錯誤。
轉載請註明出處，本文鏈接：https://www.uj5u.com/shujuku/464238.html