（已解决）我又来了，关于个提取同目录下文件夹内图片文件名称的问题

excelkill

年末岁初，各种报表统计不断，近几年在论坛里得到了各位老师的帮助很大，使我在工作上省去了很多的重复劳动，但vba真的不是朝夕就能学会了的，我这从去年开始用于报表和各种工作，一直都是麻烦论坛里各位老师的帮助，非常感谢，也提前给各位老师拜个早年，祝各位老师新年快乐、万事如意！

       这个表用于统计目录下，同编号的文件夹下的图像文件名字的汇总，数据量大概有800左右，图像文件的命名需要我手工修改，这个我想了再三，确实没法去根据图像的特征来判断分类，具体的需求我在文件里做了表述，麻烦哪位老师帮我看看，非常感谢。

fzxba

Sub test1() '
  Dim strPath As String, strFile As String, strText As String
  Dim a, b, ar, br() As String, i As Long, j As Long
  a = Array("审批表", "制度", "协议", "规定")
  b = Array("工资表", "工资凭单", "凭证", "规则")
  ar = Range("A1").CurrentRegion.Columns(4).Offset(1)
  ReDim br(1 To UBound(ar) - 1, 1 To 4)
  For i = 1 To UBound(ar) - 1
    strPath = ThisWorkbook.Path & "\名单\" & ar(i, 1)
    If Len(Dir(strPath, vbDirectory)) Then
      strText = vbNullString
      strFile = Dir(strPath & "\*.jpg")
      While Len(strFile)
        strText = strText & strFile
        strFile = Dir
      Wend
      If InStr(strText, a(0)) Then br(i, 1) = "有" Else br(i, 1) = "无"
      For j = 0 To 3
        If j > 0 Then If InStr(strText, a(j)) Then br(i, 2) = br(i, 2) & "、" & a(j)
        If InStr(strText, b(j)) Then br(i, 3) = br(i, 3) & "、" & b(j)
      Next
      For j = 2 To 3
        br(i, j) = Mid(br(i, j), 2)
      Next
    End If
  Next
  Range("H2").Resize(UBound(br), UBound(br, 2)) = br
  Beep
End Sub

excelkill

静候老师们的帮助，谢谢

shiruiqiang

主要是文件命名头疼，需要判断

ykcbf1100

用正则提取文件名
附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.2.4
   
2.     Set Fso = CreateObject("scripting.filesystemobject")
   
3.     Set reg = CreateObject("VBScript.Regexp")
   
4.     Application.ScreenUpdating = False
   
5.     st1 = [{"制度","协议","规定"}]
   
6.     st2 = [{"工资表","工资凭单","凭证"}]
   
7.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
8.     On Error Resume Next
   
9.     p = ThisWorkbook.Path & ""
   
10.     p1 = p & "名单"
    
11.     With sh
    
12.         r = .Cells(Rows.Count, 4).End(3).Row
    
13.         .[h2:j8] = ""
    
14.         arr = .Range("a1:k" & r)
    
15.         With reg
    
16.             .Pattern = "\d+"
    
17.             For i = 2 To UBound(arr)
    
18.                 p2 = p1 & CStr(arr(i, 4)) & ""
    
19.                 st = "": k1 = "": k2 = ""
    
20.                 For Each f In Fso.GetFolder(p2).Files
    
21.                     s = .Replace(Fso.GetBaseName(f), "")   '//用正则把文件名中的数字替换为空
    
22.                     st = st & "|" & s
    
23.                 Next f
    
24.                 If InStr(st, "审批表") Then arr(i, 8) = "有" Else arr(i, 8) = "无"
    
25.                 For x = 1 To UBound(st1)
    
26.                     If InStr(st, st1(x)) Then k1 = k1 & IIf(InStr(k1, st1(x)), k1, "、" & st1(x))
    
27.                 Next
    
28.                 For x = 1 To UBound(st2)
    
29.                     If InStr(st, st2(x)) Then k2 = k2 & IIf(InStr(k2, st2(x)), k2, "、" & st2(x))
    
30.                 Next
    
31.                 arr(i, 9) = Mid(k1, 2): arr(i, 10) = Mid(k2, 2)
    
32.             Next
    
33.         End With
    
34.         .Range("a1:k" & r) = arr
    
35.     End With
    
36.     Application.ScreenUpdating = True
    
37.     MsgBox "OK！"
    
38. End Sub
    

复制代码

shiruiqiang

800多个编号，建议直接遍历、自动生成

shiruiqiang

ykcbf1100 发表于 2024-2-4 22:16
用正则提取文件名
附件供参考。。。

800多个文件夹，我是通过字典嵌套，自动生成。
向ykcbf1100老师学习了一下，是可以通过正则式判断文件名

半百

wanghan519

其实，识别图片里的标题再重命名也行，用的是论坛大佬分享的接口