1234

ExcelHome技术论坛

用户名  找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

帖子
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 274|回复: 3

二次用字典Dictionary,转不过弯了。

[复制链接]

TA的精华主题

TA的得分主题

发表于 2025-1-2 11:48 | 显示全部楼层 |阅读模式




第一步用Dictionary非常简单
image.png


     For ii = 1 To Rng.Rows.Count
         oDate = Format(Rng(ii, 1), "yyyy/mm/dd hh:mm")
         Dict(oDate) = ""
     Next ii


image.png

第二次用Dictionary转不弯

         For jj = 1 To Rng.Rows.Count
         oDate = Format(Rng(jj, 1), "yyyy/mm/dd hh:mm")
         'Debug.Print Dict.Keys(ii) = oDate, Dict.Keys(ii); oDate
         If Dict.Keys(ii) = oDate Then
             oDict(Rng(ii, 1)) = Rng(ii, 2).Address
         Else
             Dict.Keys(ii) = oDict.Items
         End If
         Next jj

目的


表2的单元格地址,与表的想对应。
image.png


  1. Sub MergeAndSortSheets()
  2.     Dim Sht1 As Worksheet, Sht2 As Worksheet, Sht3 As Worksheet
  3.     Dim lastRow1 As Long, lastRow2 As Long, lastRow3 As Long
  4.     Dim ii As Long, jj As Long
  5.     Dim Dict1 As Dictionary, Dict2 As Dictionary
  6.     Dim Dict As Dictionary
  7.         Set Sht1 = Sheets(1)
  8.            Sht1.Name = "First"
  9.         Set Sht2 = Sheets(2)
  10.            Sht2.Name = "Second"
  11.         Set Sht3 = Sheets(3)
  12.         With Sht3
  13.             .Cells.Clear
  14.             .Cells.Font.Size = 9
  15.             If .Name <> "MergedSorted" Then
  16.                 .Name = "MergedSorted"
  17.             End If
  18.             .Activate
  19.         End With
  20.         Dim Rng1 As Range, Rng2 As Range, Rng3 As Range
  21.            Set Rng1 = Sht1.Cells(15, 1).CurrentRegion
  22.            Rng1.Copy
  23.            
  24.            Set Rng2 = Sht2.Cells(15, 1).CurrentRegion
  25.            Sht3.Cells(5, 1).PasteSpecial Paste:=xlPasteAll
  26.            Set Rng3 = Sht3.Cells(10, 1).CurrentRegion
  27.            Set Dict = DateDict(Rng3)
  28.            Set aa = Dict.Items(1)
  29.            
  30.            Stop
  31.            Stop
  32.    
  33. End Sub
  34. Function DateDict(Rng As Range)
  35.    Debug.Print Rng.Address; Rng.Parent.Name
  36.    Dim Dict As Dictionary, oDict As Dictionary
  37.        Set Dict = New Dictionary
  38.        Set oDict = New Dictionary
  39.    Dim oDate As Date
  40.      
  41.      For ii = 1 To Rng.Rows.Count
  42.          oDate = Format(Rng(ii, 1), "yyyy/mm/dd hh:mm")
  43.          Dict(oDate) = ""
  44.      Next ii
  45.      For ii = 0 To Dict.Count - 1
  46.          
  47.          For jj = 1 To Rng.Rows.Count
  48.          oDate = Format(Rng(jj, 1), "yyyy/mm/dd hh:mm")
  49.          'Debug.Print Dict.Keys(ii) = oDate, Dict.Keys(ii); oDate
  50.          If Dict.Keys(ii) = oDate Then
  51.              oDict(Rng(ii, 1)) = Rng(ii, 2).Address
  52.          Else
  53.              Dict.Keys(ii) = oDict.Items
  54.          End If
  55.          Next jj
  56.      Next ii
  57.      
  58.      Set DateDict = Dict
  59.      
  60. End Function
复制代码


del.zip

34.24 KB, 下载次数: 8

TA的精华主题

TA的得分主题

 楼主| 发表于 2025-1-3 14:14 | 显示全部楼层
弯弯绕,头绪不清楚,结果不对。学习学习,再学习。


  1. Function JpgFilesToDict(oFiles As Files, Dict As Scripting.Dictionary) As Scripting.Dictionary
  2.      'Dim Dict As Dictionary
  3.      Dim Img As Wia.ImageFile
  4.          Set Img = New Wia.ImageFile
  5.      Dim oFile As File
  6.          Kk = 1
  7.          For Each oFile In oFiles
  8.               With oFile
  9.                   '''
  10.                   If InStr(UCase(.Type), "JP") > 0 Then
  11.                       Set Dict(oFile.Path) = oFile
  12.                   End If
  13.               End With
  14.          Next oFile
  15.          Set JpgFilesToDict = Dict
  16. End Function

  17. Sub TraverJpgToPpt()
  18.     Dim Rng As Range
  19.         Set Rng = Selection
  20.     Dim Sht As Worksheet
  21.         Set Sht = Rng.Parent
  22.    
  23.     Dim Dict As Scripting.Dictionary
  24.         Set Dict = New Scripting.Dictionary
  25.     Dim Fso As Scripting.FileSystemObject
  26.         Set Fso = New Scripting.FileSystemObject
  27.     Dim oFolder As Folder
  28.     Dim Fia As FileDialog

  29.     Dim Files As Files
  30.         Set oFolder = Fso.GetFolder(ThisWorkbook.Path)
  31.         Set Dict = JpgFilesToDict(oFolder.Files, Dict)
  32.         
  33.    Dim Pres As Presentation, Sld As Slide

  34.        Set Fso = New FileSystemObject

  35.       
  36.        FileName = ThisWorkbook.Path & "" & Sht.Name & ".Ppt"
  37.        If Fso.FileExists(FileName) = True Then
  38.              Fso.DeleteFile FileName, True
  39.        End If
  40.    Dim oFile As File

  41.        FileName = ThisWorkbook.Path & "" & oFolder.Name & ".Ppt"
  42.        If Fso.FileExists(FileName) Then
  43.             Fso.DeleteFile FileName
  44.        End If
  45.        Set Pres = OpenPpt(Fso, FileName)
  46.        DictToPpt Fso, oFolder, Pres, Dict
  47.       
  48. End Sub
  49. ''
  50. Function DictToPpt(Fso As FileSystemObject, oFolder As Folder, Pres As Presentation, Dict As Scripting.Dictionary)
  51.        ''

  52.        With Pres.PageSetup
  53.             .SlideWidth = 960
  54.             .SlideHeight = 540
  55.        End With
  56.        ''
  57.        For ii = 0 To Dict.Count - 1

  58.            Set oFile = Dict.Items(ii) ' Fso.GetFile(ThisWorkbook.Path & "" & Rng(ii, 2))
  59.            
  60.            
  61.            Set Sld = Pres.Slides.Add(Pres.Slides.Count + 1, ppLayoutBlank)
  62.            With Sld
  63.                  .Name = oFile.Name
  64.                   .NotesPage.Shapes(2).TextFrame.TextRange.text = oFile.Name
  65.            End With
  66.            With Pres.PageSetup
  67.                 Set Shp = Sld.Shapes.AddPicture(oFile.Path, msoCTrue, msoCTrue, 0, 0, .SlideWidth, .SlideHeight)
  68.            End With
  69.            
  70.            Set Shp = Sld.Shapes.AddTextbox(msoTextOrientationHorizontal, 700, 425, 260, 220)
  71.            With Shp
  72.                .Fill.ForeColor.RGB = 16247774 'RGB(100, 0, 0)
  73.                .Name = "Txt"
  74.                .TextFrame.AutoSize = 0
  75.                .TextFrame.TextRange.text = "File:" & oFile.Name
  76.            End With
  77.            
  78.        Next ii
  79.        Pres.Save
  80.        With Pres.PageSetup
  81.             '.SlideWidth = 960 * 0.2
  82.             '.SlideHeight = 540 * 0.2
  83.        End With
  84.        Pres.SaveAs oFolder.Path & "\Del.Ppt"
  85.       
  86. End Function
复制代码

TA的精华主题

TA的得分主题

 楼主| 发表于 2025-1-5 13:09 | 显示全部楼层
ning84 发表于 2025-1-3 14:14
弯弯绕,头绪不清楚,结果不对。学习学习,再学习。

学习Dictionary学习Dictionary,再学习Dictionary。

  1. Function JpgFilesToDict(oFiles As Files, Dict As Scripting.Dictionary) As Scripting.Dictionary


  2.      Dim oFile As File
  3.          Kk = 1
  4.          For Each oFile In oFiles
  5.               With oFile
  6.                   '''
  7.                   If InStr(UCase(.Type), "JP") > 0 Then
  8.                       Set Dict(oFile.Path) = oFile
  9.                   End If
  10.               End With
  11.          Next oFile
  12.          Set JpgFilesToDict = Dict
  13. End Function

  14. Sub TraverJpgToPpt()
  15.     Dim Rng As Range
  16.         Set Rng = Selection
  17.     Dim Sht As Worksheet
  18.         Set Sht = Rng.Parent
  19.    
  20.     Dim Dict As Scripting.Dictionary
  21.         Set Dict = New Scripting.Dictionary
  22.     Dim Fso As Scripting.FileSystemObject
  23.         Set Fso = New Scripting.FileSystemObject
  24.     Dim oFolder As Folder
  25.     Dim Fia As FileDialog

  26.     Dim Files As Files
  27.         Set oFolder = Fso.GetFolder(ThisWorkbook.Path)
  28.         Set Dict = JpgFilesToDict(oFolder.Files, Dict)
  29.         
  30.    Dim Pres As Presentation, Sld As Slide

  31.        Set Fso = New FileSystemObject

  32.       
  33.        FileName = ThisWorkbook.Path & "" & Sht.Name & ".Ppt"
  34.        If Fso.FileExists(FileName) = True Then
  35.              Fso.DeleteFile FileName, True
  36.        End If
  37.    Dim oFile As File

  38.        FileName = ThisWorkbook.Path & "" & oFolder.Name & ".Ppt"
  39.        If Fso.FileExists(FileName) Then
  40.             Fso.DeleteFile FileName
  41.        End If
  42.        Set Pres = OpenPpt(Fso, FileName)
  43.        DictToPpt Fso, oFolder, Pres, Dict
  44.       
  45. End Sub
  46. ''
  47. Function DictToPpt(Fso As FileSystemObject, oFolder As Folder, Pres As Presentation, Dict As Scripting.Dictionary)
  48.        ''
  49.     Dim Sld As Slide
  50.     Dim oFile As File
  51.     Dim Shp1, Shp2
  52.     Dim sArr(1) 'As Shape
  53.        With Pres.PageSetup
  54.             .SlideWidth = 960
  55.             .SlideHeight = 540
  56.        End With
  57.        ''
  58.        For ii = 0 To Dict.Count - 1

  59.            Set oFile = Dict.Items(ii)
  60.            
  61.            
  62.            Set Sld = Pres.Slides.Add(Pres.Slides.Count + 1, ppLayoutTitle)
  63.            With Sld
  64.                  .Name = oFile.Name
  65.                   .NotesPage.Shapes(2).TextFrame.TextRange.text = oFile.Name
  66.                  
  67.            End With
  68.            With Pres.PageSetup
  69.                 Set Shp = Sld.Shapes.AddPicture(oFile.Path, msoCTrue, msoCTrue, 0, 0, .SlideWidth, .SlideHeight)
  70.                Shp.ZOrder msoBringToback
  71.            End With
  72.            
  73.            Set Shp = Sld.Shapes.AddTextbox(msoTextOrientationHorizontal, 2, 5, 460, 10)
  74.            With Shp
  75.                '.Fill.ForeColor.RGB = 16247774 'RGB(100, 0, 0)
  76.                .Name = "Txt"
  77.                .TextFrame.AutoSize = 0
  78.                .TextFrame.TextRange.text = "File:" & oFile.Name
  79.                
  80.            End With
  81.            With Sld
  82.                 For Kk = 0 To 1
  83.                    Set sArr(Kk) = .Shapes(1 + Kk)
  84.                   sArr(Kk).TextFrame.TextRange.text = "标题栏" & Kk + 1
  85.                 Next Kk
  86.            End With
  87.        Next ii
  88.        Pres.Save
  89.       
  90. End Function

复制代码
]

TA的精华主题

TA的得分主题

发表于 2025-1-5 14:19 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
把代码拆分一下,一个sub这么多,不合理,最好是用call的方法写sub
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

1234

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2025-2-17 20:45 , Processed in 0.035551 second(s), 11 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表