Dictionary套用Dictionary

ning84 · 发表于 2025-3-28 15:18

Sub lll()
Dim Dict As Scripting.Dictionary
Set Dict = New Scripting.Dictionary
Set Dict1 = New Scripting.Dictionary
Set Dict2 = New Scripting.Dictionary
Dim Sht As Worksheet, Rng As Range
Set Sht = Sheet1
Dim oRow
With Sht
For jj = 2 To 5
oRow = .Cells(.Rows.Count, jj).End(xlUp).Row
Set Rng = .Range(.Cells(4, jj), .Cells(oRow, jj))
Set Dict(ShtDict(Rng)) = ShtDict(Rng)
Next jj
End With
Dim tmpDict As Scripting.Dictionary
For ii = 0 To Dict.Count - 1
Set tmpDict = Dict.Keys(ii)
Debug.Print tmpDict.Count,
For Each Key In tmpDict.Keys
Set Rng = Key
Debug.Print Rng.Address,
Next Key
Debug.Print
Next ii
End Sub
Function ShtDict(Rng As Range)
Dim Dict As Scripting.Dictionary
Set Dict = New Scripting.Dictionary
For ii = 1 To Rng.Rows.Count
Set Dict(Rng(ii, 1)) = Rng(ii, 1)
Next ii
Set ShtDict = Dict
End Function

复制代码

5          $B$4       $B$5       $B$6       $B$7       $B$8
10          $C$4       $C$5       $C$6       $C$7       $C$8       $C$9       $C$10       $C$11       $C$12       $C$13
3          $D$4       $D$5       $D$6
13          $E$4       $E$5       $E$6       $E$7       $E$8       $E$9       $E$10       $E$11       $E$12       $E$13       $E$14       $E$15       $E$16

ning84 · 发表于 2025-4-5 11:14

For Each key In Dict.keys

Sub SlelctShtToAimFolder()
Dim Fso As Scripting.FileSystemObject, oFolder As Folder
Set Fso = New Scripting.FileSystemObject
Dim Sht As Worksheet
Set Sht = Application.ActiveSheet
Dim SheetDate As Date
SheetDate = CDate(Sht.Name)
Set oFolder = CheckFolder(Fso, Sht)
Dim CurrentFolder As Folder, AimFolder As Folder
Set AimFolder = oFolder
Dim FileDict As Scripting.Dictionary
Set FileDict = New Scripting.Dictionary
''
Dim CameraDict As Scripting.Dictionary, ScreenDict As Scripting.Dictionary
Set CameraDict = New Scripting.Dictionary
Set ScreenDict = New Scripting.Dictionary
Set CurrentFolder = Fso.GetFolder(ThisWorkbook.Path & "\JPG") ' & Sht.Name)
'''
Dim PathName
PathName = ThisWorkbook.Path
Dim oDate As Date
oDate = SheetDate
''
For Each oFile In CurrentFolder.Files
If Format(oFile.DateLastModified, "yyyy/mm/dd") = oDate Then
If InStr(oFile.Name, "IMG") > 0 Or InStr(oFile.Name, "Screenshot") > 0 Then
Set FileDict(oFile) = Nothing
End If
End If
Next oFile
''
With FileDict
For Each key In .keys 'ii = 0 To .Count - 1
Debug.Print ii, AimFolder & "" & key.Name; '' .keys(ii).Name
Fso.MoveFile .keys(ii), AimFolder & "" & key.Name ''.keys(ii).Name
Next key ' ii
End With
End Sub

复制代码

ning84 · 发表于 2025-4-15 13:21

本帖最后由 ning84 于 2025-4-15 22:23 编辑

Function CameraGroupTimeDict(folderFileDict As Scripting.Dictionary, intervalThreshold As Long) As Scripting.Dictionary
Dim resultDict As Scripting.Dictionary
Set resultDict = New Scripting.Dictionary
Dim pptDict As Scripting.Dictionary
Set pptDict = New Scripting.Dictionary
Dim i As Long
Dim File1 As File, File2 As File
Dim date1 As Date, date2 As Date
For i = 0 To folderFileDict.Count - 2
Set File1 = folderFileDict.keys(i)
Set File2 = folderFileDict.Items(i)
Set pptDict(File1) = File2
If Not File2 Is Nothing Then
date1 = CDate(folderFileDict.keys(i).DateLastModified)
date2 = CDate(folderFileDict.keys(i + 1).DateLastModified)
If Abs(DateDiff("s", date1, date2)) >= intervalThreshold Then
'Set resultDict(File1) = File2
'Debug.Print DateDiff("s", date1, date2), date1, date2
Set resultDict(pptDict) = pptDict
Set pptDict = New Scripting.Dictionary
End If
End If
Next i
If pptDict.Count > 0 Then
Set resultDict(pptDict) = pptDict
End If
Set CameraGroupTimeDict = resultDict
End Function
'''
Sub lll()
Dim Sht1 As Worksheet, Sht2 As Worksheet
Dim Rng1 As Range, Rng2 As Range
Dim oRow
Set Sht1 = Sheet1
With Sht1
.Cells.Font.Size = 9
oRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If oRow < 5 Then
oRow = 3
End If
Set Rng1 = .Cells(oRow, 1)
End With
''
Set Sht2 = Application.ActiveSheet
With Sht2
.Cells.Clear
.Cells.Font.Size = 9
Set Rng2 = .Cells(5, 1)
End With
If Sht1.Name = Sht2.Name Then
MsgBox "Error"
Exit Sub
End If
Debug.Print Sht1.Name, Sht2.Name
Dim ii, jj, kk, Str
Dim Fso As Scripting.FileSystemObject
Set Fso = New Scripting.FileSystemObject
Dim oFolder As Folder, oFile As File
Dim CameraGroupDict As Scripting.Dictionary
Set CameraGroupDict = New Scripting.Dictionary
Dim Dict As Scripting.Dictionary
Dim PathName As String
'Set Dict = New Scripting.Dictionary
PathName = ThisWorkbook.Path & "\JPG"
Set oFolder = Fso.GetFolder(PathName)
Debug.Print oFolder.Name, oFolder.Path
''
For Each oFile In oFolder.Files
If InStr(oFile.Name, "IMG") > 0 Then
Set CameraGroupDict(oFile) = oFile
End If
Next oFile
'''
Set CameraGroupDict = CameraGroupTimeDict(CameraGroupDict, 20 * 60)
CameraGroupDictSht CameraGroupDict, Fso, PathName, Rng1, Rng2
'''
End Sub
Function CameraGroupDictSht(CameraGroupDict As Scripting.Dictionary, Fso As Scripting.FileSystemObject, PathName, Rng1 As Range, Rng2 As Range)
'''
Dim Sht1 As Worksheet, Sht2 As Worksheet
Dim oRow1 As Integer, oRow2 As Integer
Set Sht1 = Rng1.Parent
Set Sht2 = Rng2.Parent
'Debug.Print Sht1.Name, Sht2.Name
Dim File1 As File, File2 As File
Dim Str, ii As Integer, jj As Integer, kk As Integer
Dim oRow As Integer
oRow1 = Rng1.Row + 3
oRow2 = Rng2.Row
Dim Dict As Scripting.Dictionary
For Each Dict In CameraGroupDict '.Keys
'Set Dict = CameraGroupDict.Keys(ii)
With Dict
''Debug.Print .Count
Set File1 = Dict.keys(0)
Set File2 = .keys(.Count - 1)
Str = Format(File1.DateLastModified, "yyyymmdd") & "_" & Format(File1.DateLastModified, "hhmm") & "-" & Format(File2.DateLastModified, "hhmm")
With Sht1
.Cells(oRow1, 2) = Str
PathName = ThisWorkbook.Path & "" & Str
If Fso.FolderExists(PathName) Then
Debug.Print PathName
Else
Debug.Print "Not Folder "; PathName
End If
''
Str = Sht2.Name & "!" & Sht2.Cells(oRow2, 2).Resize(Dict.Count - 1, 1).Address(0, 0)
'Debug.Print Str
.Cells(oRow1, 1) = Str
EngDateStr = "Stree Snap From " & Format(File1.DateLastModified, "h:mm") & " to " & Format(File2.DateLastModified, "h:mm") & " on " & Format(File1.DateLastModified, "mmmm d,yyyy")
.Cells(oRow1, 4) = EngDateStr
ChiDateStr = Format(File1.DateLastModified, "yyyy年m月d日h:mm") & "到" & Format(File2.DateLastModified, "h:mm") & "的街拍"
.Cells(oRow1, 3) = ChiDateStr
End With
'''
For ii = 1 To Dict.Count - 1
Str = Dict.keys(ii).Name
Sht2.Cells(oRow2, 2) = Str
oRow2 = oRow2 + 1
Next ii
End With
oRow1 = oRow1 + 1
oRow2 = oRow2 + 5
Next Dict
End Function
Private Sub llll()
Dim Arr
Dim Rng As Range, oRng As Range
Set Rng = Sheets("Item").Cells(12, 1)
Debug.Print Rng.Address, Rng
Dim Sht As Worksheet
Arr = Split(Rng, "!")
Set Sht = Sheets(Arr(0))
Set Rng = Sht.Range(Arr(1))
Debug.Print Rng.Address
Sht.Activate
Rng.Select
End Sub

复制代码

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

Dictionary套用Dictionary

浏览过的版块