.Transpose(.Transpose(Arr)数组转置，Dictionary如何转置？

ning84 · 发表于 2024-5-25 11:01

Sub lll()
Dim Arr(1)
Arr(0) = Array(1, 2, 3)
Arr(1) = Array(4, 5, 6)
With Application.WorksheetFunction
Sheet1.Cells(1, 1).Resize(2, 3) = .Transpose(.Transpose(Arr))
End With
Stop
End Sub

复制代码

.Transpose(.Transpose(Arr)数组转置结果，如下。

*****************
二楼问的主题，字典如何转置？？上图结果。

ning84 · 发表于 2024-5-25 11:14

.Transpose(.Transpose(Dict.Items))的应用？

Sub ll2()
Dim Dict As Dictionary
Set Dict = New Dictionary
Dim Arr(1)
Arr(0) = Array(1, 2, 3)
Arr(1) = Array(4, 5, 6)
For ii = 0 To 1
Dict("ii" & ii) = Arr(ii)
Next ii
''
With Application.WorksheetFunction
Sheet1.Cells(6, 1).Resize(Dict.Count, 1) = .Transpose(Dict.Keys)
Sheet1.Cells(6, 3).Resize(Dict.Count, 3) = .Transpose(.Transpose(Dict.Items))
Sheet1.Cells(1, 1).Resize(2, 3) = .Transpose(.Transpose(Arr))
End With
Stop
End Sub

复制代码

字典运行结果。

gwjkkkkk · 发表于 2024-5-25 13:41

keys或items可以当成一维数组进行转置。。。

opiona · 发表于 2024-5-26 19:07

转置后数组元素个数可能会丢失
Keys 是唯一值但是Items 可以重复
转置后 Items 变 Keys 元素可能会少

ning84 · 发表于 2024-5-28 19:07

Sub Test()
t = Time
Dim Dict0 As Dictionary
Set Dict0 = New Dictionary
Set Dict1 = New Dictionary
Set Dict2 = New Dictionary
Set FolderDict = New Dictionary
Dim Rng As Range, R1 As Range, R2 As Range
Set Rng = Selection
Dim Sht As Worksheet
Sht.Cells.Clear
Dim Rr, Cc
Rr = 10
Cc = 4
Dim Fso As FileSystemObject
Set Fso = New FileSystemObject
Dim oFolder As Folder, oFile As File
Set oFolder = Fso.GetFolder(ThisWorkbook.Path )
If oFolder.SubFolders.Count = 0 And oFolder.Files.Count > 0 Then
TraverseFolderFile oFolder
Else
TraverseSubFolders oFolder
End If
With Application.WorksheetFunction
Sht.Cells(Rr, 1).Resize(Dict1.Count, 1) = .Transpose(Dict1.Keys)
Sht.Cells(Rr, Cc + 15).Resize(Dict2.Count, 1) = .Transpose(Dict2.Keys)
Sht.Cells(Rr, Cc + 18).Resize(FolderDict.Count, 1) = .Transpose(FolderDict.Keys)
Sht.Cells(Rr, Cc + 19).Resize(FolderDict.Count, 1) = .Transpose(FolderDict.Items)
End With
Sht.Cells(1, 1) = "Not Repeat Files " & Dict1.Count
Sht.Cells(1, 2) = "Total Files " & Dict2.Count
Sht.Cells(1, 3) = "Total Folder " & FolderDict.Count
''Debug.Print
With Dict1
'''
For ii = 0 To Dict1.Count - 1
Set Dict0 = RepeatDict(.Keys(ii), .Items(ii), Dict2)
Debug.Print Dict0.Count
If Dict0.Count > 0 Then
With Application.WorksheetFunction
Sht.Cells(Rr + ii, Cc) = Dict0.Count
Sht.Cells(Rr + ii, Cc + 1) = .Transpose(.Transpose(Dict0.Keys))
Sht.Cells(Rr + ii, Cc + 1) = .Transpose(Dict0.Keys) '.Transpose(.Transpose(Dict0.Keys))
Sht.Cells(Rr + ii, Cc + 1).Resize(, Dict0.Count) = .Transpose(Dict0.Keys) '.Transpose(.Transpose(Dict0.Keys))
End With
End If
Next ii
End With
Sht.Cells(3, 1) = Format(Time - t, "h:mm:ss")
End Sub
Function RepeatDict(Str1, Str2, Dict As Dictionary)
Dim oDict As Dictionary
Set oDict = New Dictionary
For ii = 0 To Dict.Count - 1
'Debug.Print Str1, Dict.Items(ii), Str2, Dict.Keys(ii)
If Str1 = Dict.Items(ii) And Str2 <> Dict.Keys(ii) Then
oDict(Dict.Keys(ii)) = ""
End If
Next ii
'Debug.Print oDict.Count
Set RepeatDict = oDict
End Function
Sub TraverseSubFolders(oFolder As Folder)
Dim SubFolder As Folder
For Each SubFolder In oFolder.SubFolders
FolderDict(SubFolder.Name) = SubFolder.Path
TraverseFolderFile SubFolder
TraverseSubFolders SubFolder
Next SubFolder
End Sub
Function TraverseFolderFile(oFolder As Folder)
Dim oFile As File
For Each oFile In oFolder.Files
'Debug.Print , oFile.Path
Dict1(oFile.Name) = oFile.Path
Dict2(oFile.Path) = oFile.Name
Next oFile
End Function

复制代码

		自动登录	找回密码
密码			免费注册

.Transpose(.Transpose(Arr)数组转置，Dictionary如何转置？

最新热点 /1