在多列上将垂直转换为水平
Convert vertical to horizontal on multiple columns
我有一个代码可以将一列从垂直状态转换为水平状态（每组在一行中）
这是一些虚拟数据
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
第二列的代码工作正常，但我也需要用同样的想法处理第三列。至于第四列将只有一次（在输出中将在一列中）
这是预期的输出
您的问题的解决方案比乍看起来要复杂一些。但是感谢您使用字典而不是尝试通过数组来做所有事情。
下面的代码使用了一个字典，其键是组列中的值。与这些键关联的 Item 是一个 Arraylist。反过来，Arraylist 填充有 Arraylists，其中包含与 Group Column 中的 Key 对应的每一行的 Amount、Note 和 Nname 值。使用 Arraylist 是因为我们可以很容易地从 Arraylist 中删除项目。
请注意，Scripting.Dictionaries 和 ArrayLists 的 Item 方法是默认方法，因此我没有在代码中显式调用 Item 方法。如果默认方法不是 Item，那么我会特别说明默认方法。
下面的代码比您原来的 post 长很多，但我希望您能看到事情是如何分解成逻辑任务的。
您还会看到我经常使用垂直间距来将带有方法的代码分解为 'paragraphs'。这是个人喜好。
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
我做的有点不同：
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") 输入正确的引用。为您不想扩展到此数组的列添加 headers：arrNotExpand = Array("Name")。照原样，您将获得预期的输出。假设您也添加了“金额”，所以：arrNotExpand = Array("Amount", "Name")，那么您将得到：
如果您向范围中添加更多列，则此方法有效。只需确保您所有的 headers 都是唯一的（否则您将 运行 分配新的 dict.keys 时出错）。如果有任何不清楚的地方，或者您发现错误，请告诉我。
我有一个代码可以将一列从垂直状态转换为水平状态（每组在一行中） 这是一些虚拟数据
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
第二列的代码工作正常，但我也需要用同样的想法处理第三列。至于第四列将只有一次（在输出中将在一列中）
这是预期的输出
您的问题的解决方案比乍看起来要复杂一些。但是感谢您使用字典而不是尝试通过数组来做所有事情。
下面的代码使用了一个字典，其键是组列中的值。与这些键关联的 Item 是一个 Arraylist。反过来，Arraylist 填充有 Arraylists，其中包含与 Group Column 中的 Key 对应的每一行的 Amount、Note 和 Nname 值。使用 Arraylist 是因为我们可以很容易地从 Arraylist 中删除项目。
请注意，Scripting.Dictionaries 和 ArrayLists 的 Item 方法是默认方法，因此我没有在代码中显式调用 Item 方法。如果默认方法不是 Item，那么我会特别说明默认方法。
下面的代码比您原来的 post 长很多，但我希望您能看到事情是如何分解成逻辑任务的。
您还会看到我经常使用垂直间距来将带有方法的代码分解为 'paragraphs'。这是个人喜好。
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
我做的有点不同：
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") 输入正确的引用。为您不想扩展到此数组的列添加 headers：arrNotExpand = Array("Name")。照原样，您将获得预期的输出。假设您也添加了“金额”，所以：arrNotExpand = Array("Amount", "Name")，那么您将得到：
如果您向范围中添加更多列，则此方法有效。只需确保您所有的 headers 都是唯一的（否则您将 运行 分配新的 dict.keys 时出错）。如果有任何不清楚的地方，或者您发现错误，请告诉我。