本帖最后由 ADSL0125 于 2013-8-21 00:56 编辑
回复 1# 001011
VBA调用API来排序,需要电脑上装有Excel 2003或以上
分选择文件夹和重命名两步,重命名前可以先看到准备改为的名字- Option Explicit
-
- Declare Function StrCmpLogicalW Lib "shlwapi" (ByVal S1 As String, ByVal S2 As String) As Integer
-
- '2.重命名
- Public Sub Rename()
-
- '获取行数
- Dim L As Long
- L = MainSheet.Range("D1").End(xlDown).Row - 2
-
- If L < 0 Or Len(MainSheet.Range("D2").Value) = 0 Then Exit Sub '没有数据退出
-
- '重命名
- Dim F As Long, C As Long
- On Error GoTo ErrRename
- Call MainSheet.Range("E2:E50000").Clear
- For F = 0 To L
- If Len(MainSheet.Range("D2").Offset(F).Value) Then
- C = F
- MainSheet.Range("E2").Offset(F).Value = "OK"
- Name MainSheet.Range("B2").Offset(F).Value As MainSheet.Range("D2").Offset(F).Value
- End If
- Next
- GoTo EXT
-
-
-
-
- ErrRename:
- MainSheet.Range("E2").Offset(C).Value = "错误:" & Err.Description
-
- Resume Next
- EXT:
- End Sub
-
- '1.选择文件夹
- Public Sub Start()
- '获取选择路径
- Dim OFD As FileDialog
- Set OFD = Excel.Application.FileDialog(msoFileDialogFolderPicker)
-
- Call OFD.Show
- If OFD.SelectedItems.Count = 0 Then Exit Sub
-
- Dim Path As String
- Path = OFD.SelectedItems(1) & "\"
-
- '获取文件,并排序
- Dim Files() As String
-
- On Error GoTo ErrGetDirFiles
- Files = GetDirFiles(Path)
- On Error GoTo 0
-
- Files = FilesOrderByLogical(Files)
-
- '输出
- Dim F As Long, L As Long
- Call MainSheet.Range("A2:E50000").Clear
-
- L = UBound(Files)
- For F = 0 To L
- MainSheet.Range("A2").Offset(F).Value = F + 1
- MainSheet.Range("B2").Offset(F).Value = Path & Files(F)
- MainSheet.Range("C2").Offset(F).Value = GetExName(Files(F))
- MainSheet.Range("D2").Offset(F).Value = Path & "1" & Right("000" & (F + 1), 4) & "." & GetExName(Files(F))
- Next
- GoTo EXT
-
-
-
- ErrGetDirFiles:
- Call MsgBox("获取文件夹中文件发生错误,文件夹中可能没有文件", vbOKOnly)
- GoTo EXT
-
- EXT:
- End Sub
-
- '取得文件名的扩展名
- Public Function GetExName(ByVal S As String) As String
- Dim I As Long
- I = InStrRev(S, ".")
- If I = -1 Then Exit Function
- GetExName = Mid(S, I + 1)
- End Function
-
- '对数组中的字符串进行逻辑排序(升序)
- Public Function FilesOrderByLogical(ByRef Files() As String) As String()
- Dim F1 As Long, F2 As Long
- Dim L As Long
- Dim T As String
-
- L = UBound(Files)
-
- For F1 = 0 To L - 1
- For F2 = F1 + 1 To L
- If StrCmpLogicalW(StrConv(Files(F1), vbUnicode), StrConv(Files(F2), vbUnicode)) > 0 Then
- T = Files(F1)
- Files(F1) = Files(F2)
- Files(F2) = T
- End If
- Next
- Next
- FilesOrderByLogical = Files
- End Function
-
- '取得文件夹中的文件,不包含子文件夹
- Public Function GetDirFiles(ByVal Path As String) As String()
-
- Dim Files() As String
- Dim C As Long, MAXC As Long
- Dim S As String
-
- MAXC = 100
- ReDim Files(MAXC - 1)
-
- S = Dir(Path) '第一个文件
- Do While (Len(S))
- Files(C) = S
- C = C + 1
- If C > MAXC Then '超过数组范围,扩展数组
- MAXC = MAXC * 2
- ReDim Preserve Files(MAXC - 1)
- End If
- S = Dir
- Loop
-
- ReDim Preserve Files(C - 1)
- GetDirFiles = Files
- End Function
| 
发表于 2013-8-20 09:40
| 
