提取特定类型的文件名中部分字符段

zzzaqws

附件如图片所示，想针对文件夹内特定文件类型（如txt）的文件名提取两个_中间的字段提取到excel里。
之前一直用的比较笨的办法，先提取文件名，然后人工字符替换排序
但是现在工作量翻倍了，有点弄不过来，所以求助各位老师有没有什么好的办法

zzzaqws

求助各位老師！

taller

参考代码

1. Sub demo()
   
2.     Dim res()
   
3.     n = 0
   
4.     fn = Dir(ThisWorkbook.Path & "\*.txt")
   
5.     If Len(fn > 0) Then
   
6.         Do
   
7.                 Debug.Print fn
   
8.                 arr = Split(Split(fn, ".")(0), "_")
   
9.                 ReDim Preserve res(1, n)
   
10.                 res(0, n) = n + 1
    
11.                 res(1, n) = arr(1)
    
12.                 n = n + 1
    
13.             fn = Dir()
    
14.         Loop While Len(fn) > 0
    
15.     End If
    
16.     If n > 0 Then
    
17.         Range("A:B").Clear
    
18.         [a1].Resize(n, 2).Value = Application.Transpose(res)
    
19.     End If
    
20. End Sub

复制代码

taller

示例文件

提取文件名.7z (12.76 KB, 下载次数: 1)

2020-5-31 01:45 上传

点击文件名下载附件

renkangjizhen

循环获取文件名后，也可以用find提取目标值

larer

正则表达式:_(.+)_

shenjianrong163

获取指定内容后再进行排序：

1. Sub test()
   
2.     Dim k%, arr(1 To 10000, 1 To 2)
   
3.     Set fso = CreateObject("scripting.filesystemobject")
   
4.     Set sh = ActiveSheet
   
5.     Application.ScreenUpdating = False
   
6.     sh.Range("A2:B" & sh.Cells(sh.Rows.Count, 1).End(xlUp).Row + 1).ClearContents
   
7.     For Each f In fso.getfolder(ThisWorkbook.Path).Files
   
8.         If InStr(f.Name, ".txt") <> 0 Then
   
9.             k = k + 1
   
10.             arr(k, 1) = k: arr(k, 2) = Split(f.Name, "_")(1)
    
11.         End If
    
12.     Next f
    
13.     For i = 1 To k - 1
    
14.         For j = i + 1 To k
    
15.             s1 = Mid(arr(i, 2), 2, InStr(arr(i, 2), "~") - 2)
    
16.             s2 = Mid(arr(j, 2), 2, InStr(arr(j, 2), "~") - 2)
    
17.             If s1 = s2 Then
    
18.                 s1 = Right(Len(arr(i, 2)), Len(arr(i, 2)) - InStr(arr(i, 2), "~") - 1)
    
19.                 s2 = Right(Len(arr(j, 2)), Len(arr(j, 2)) - InStr(arr(j, 2), "~") - 1)
    
20.             End If
    
21.             If InStr(s1, "-") > 0 And InStr(s2, "-") > 0 Then
    
22.                 s1 = Val(Replace(s1, "-", ""))
    
23.                 s2 = Val(Replace(s2, "-", ""))
    
24.             ElseIf InStr(s1, "-") > 0 And InStr(s2, "-") = 0 Then
    
25.                 If Left(s1, 1) = Left(s2, 1) And Val(s1) = Val(s2) Then
    
26.                     s1 = Val(Replace(s1, "-", ""))
    
27.                     s2 = Val(s2)
    
28.                 Else
    
29.                     s1 = Val(s1)
    
30.                     s2 = Val(s2)
    
31.                 End If
    
32.             ElseIf InStr(s1, "-") = 0 And InStr(s2, "-") > 0 Then
    
33.                 If Left(s1, 1) = Left(s2, 1) And Val(s1) = Val(s2) Then
    
34.                     s2 = Val(Replace(s2, "-", ""))
    
35.                     s1 = Val(s1)
    
36.                 Else
    
37.                     s1 = Val(s1)
    
38.                     s2 = Val(s2)
    
39.                 End If
    
40.             Else
    
41.                 s1 = Val(s1)
    
42.                 s2 = Val(s2)
    
43.             End If
    
44.             If s1 > s2 Then
    
45.                 temp = arr(i, 2): arr(i, 2) = arr(j, 2): arr(j, 2) = temp
    
46.             End If
    
47.         Next
    
48.     Next
    
49.     sh.[A2].Resize(k, 2) = arr
    
50.     Application.ScreenUpdating = True
    
51. End Sub

复制代码

shenjianrong163

请参考附件：


提取文件名特定字符段.rar (11.83 KB, 下载次数: 3)

2020-5-31 08:12 上传

点击文件名下载附件

zzzaqws

taller 发表于 2020-5-31 01:45
参考代码

哇！多谢版主老师！看来后面要多学学VBA，太强大了!

zzzaqws

shenjianrong163 发表于 2020-5-31 08:10
获取指定内容后再进行排序：

完美解决！多谢老师！回头我慢慢琢磨！好好学学！