提取数据后 数据排列问题

haha741

我需要提取d:\1234目录下所有文件夹及每个文件夹下的子文件夹名称及文件夹内图片的数量  分别填入到excle表格的A列、B列 A列是文件夹名称B列是文件夹内照片的数量 现在代码可以准确的找到名字和数量 就是排序出现问题  下面的是输出结果  110-10-1 跑到前面去了 我需要的是每段数值都能从1-10的顺序排列   因为有几万条信息  不好核对 麻烦大神帮忙解决一下  代码在最下面
错误的排序



想要的排序

R604-2023-001-1-1        6
R604-2023-001-1-2        6
R604-2023-001-4-1-1        2
R604-2023-001-6-1        7
R604-2023-001-9-1-1        1
R604-2023-001-9-1-2        1
R604-2023-001-9-1-3        1
R604-2023-001-9-1-4        1
R604-2023-001-9-1-5        1
R604-2023-001-9-1-6        1
R604-2023-001-9-1-7        1
R604-2023-001-9-1-8        1
R604-2023-001-9-1-9        1
R604-2023-001-9-1-10        1
R604-2023-001-9-1-11        1
R604-2023-001-9-1-12        1
R604-2023-001-9-1-13        1
R604-2023-001-9-1-14        1
R604-2023-001-9-1-15        1
R604-2023-001-9-1-16        1
R604-2023-001-9-1-17        1
R604-2023-001-9-1-18        2
R604-2023-001-9-1-19        1
R604-2023-001-9-2-1        2
R604-2023-001-9-2-2        1
R604-2023-001-9-2-3        10
R604-2023-001-9-2-4        4
R604-2023-001-10-1        1
R604-2023-001-10-2        1


Sub CountPhotosInAllSubfolders()
    Dim folderPath As String
    Dim ws As Worksheet
    Dim rowCount As Long
      
    ' 设置工作表
    Set ws = ThisWorkbook.Sheets(2)
      
    ' 清除之前的数据（可选，但推荐）
    ws.Cells.Clear
      
    ' 设置标题
    ws.Cells(1, 1).Value = "文件夹名称"
    ws.Cells(1, 2).Value = "照片数量"
      
    ' 初始化行计数器
    rowCount = 2
      
    ' 设置文件夹路径
    folderPath = "D:\1234\"
      
    ' 调用递归函数
    CountPhotosInFolder ws, rowCount, folderPath
      
    ' 提示完成
    MsgBox "完成! 照片数量已统计完成并写入Excel。"
End Sub
  
' 递归函数来遍历文件夹并计算照片数量
Sub CountPhotosInFolder(ByRef ws As Worksheet, ByRef rowCount As Long, ByVal folderPath As String)
    Dim fs As Object
    Dim folder As Object
    Dim subfolder As Object
    Dim file As Object
    Dim photoCount As Long
    Dim folderName As String
      
    ' 创建文件系统对象
    Set fs = CreateObject("Scripting.FileSystemObject")
      
    ' 获取文件夹对象
    On Error Resume Next ' 忽略错误以检查文件夹是否存在
    Set folder = fs.GetFolder(folderPath)
    On Error GoTo 0 ' 恢复正常的错误处理
      
    If folder Is Nothing Then
        ' 如果文件夹不存在，则跳过
        Exit Sub
    End If
      
    ' 提取文件夹名称
    folderName = GetFolderName(folderPath)
      
    photoCount = 0
      
    ' 遍历当前文件夹下的所有文件
    For Each file In folder.files
        ' 检查文件扩展名
        If LCase(fs.GetExtensionName(file.Name)) = "jpg" Or LCase(fs.GetExtensionName(file.Name)) = "png" Then
            photoCount = photoCount + 1
        End If
    Next file
      
    ' 如果当前文件夹包含照片，则将其名称和照片数量写入Excel
    If photoCount > 0 Then
        ws.Cells(rowCount, 1).Value = folderName
        ws.Cells(rowCount, 2).Value = photoCount
        ' 更新行计数器
        rowCount = rowCount + 1
    End If
      
    ' 遍历当前文件夹下的所有子文件夹
    For Each subfolder In folder.subFolders
        ' 递归调用
        CountPhotosInFolder ws, rowCount, subfolder.path
    Next subfolder
End Sub
  
' 辅助函数，用于从文件夹路径中提取文件夹名称
Function GetFolderName(ByVal folderPath As String) As String
    Dim pos As Integer
    pos = InStrRev(folderPath, "\")
    If pos > 0 Then
        GetFolderName = Mid(folderPath, pos + 1)
    Else
        GetFolderName = folderPath ' 如果路径没有斜杠，则整个路径就是文件夹名（但这种情况不太可能发生）
    End If
End Function

longwin

加个辅助列排序，排完后也可以删掉辅助列
Sub test()
arr = [a1].CurrentRegion
For i = 2 To UBound(arr)
    ml = arr(i, 1)
    mr = Split(ml, "-")
    For j = 3 To UBound(mr)
        mr(j) = Format(mr(j), "000")
    Next
    arr(i, 1) = Join(mr, "-")
Next
[c1].Resize(UBound(arr), 1) = arr
[c1] = "辅助列"
Set Rng = [a1].CurrentRegion
Rng.Sort Key1:="辅助列", Header:=xlYes
End Sub

limonet

楼主的键盘缺了几个键吗？没有看到标点符号。

haha741

longwin 发表于 2024-7-4 18:21
加个辅助列排序，排完后也可以删掉辅助列
Sub test()
arr = [a1].CurrentRegion

感谢你的帮助 我先下载看下 谢谢

haha741

limonet 发表于 2024-7-4 22:30
楼主的键盘缺了几个键吗？没有看到标点符号。

标点符号用空格代替了  没文化 让你见笑了  如果你能帮助我解决问题或者提出点思路 在说风凉话我也给你点个赞 说声谢谢   但你的这种行为我只能理解为你的素质太差！！！  最后送你三个标点符号

ming0018

API 有个自然排序法
Private Declare Function StrCmpLogicalW Lib "Shlwapi" (ByVal psz1 As Long, ByVal psz2 As Long) As Long

算法自己用冒泡或者更快的希尔排序法就行了

grf1973

用js可以无限累加排序条件。。。。。

limonet

haha741 发表于 2024-7-5 10:14
标点符号用空格代替了  没文化 让你见笑了  如果你能帮助我解决问题或者提出点思路 在说风凉话我也给你 ...

学会尊重，汉语是包括标点符号的，跟文化没有关系。

haha741

limonet 发表于 2024-7-5 11:32
学会尊重，汉语是包括标点符号的，跟文化没有关系。

真是搞笑 最少我还贡献个查文件夹图片的代码 你做了什么？ 是我没用标点符号就不尊重人了还是你讽刺人是尊重？ 你不配谈尊重

haha741

grf1973 发表于 2024-7-5 11:27
用js可以无限累加排序条件。。。。。

感谢老师帮助 谢谢