Question

如何在excel中使用VBA快速排列照片名字中的序号

现有如下一组照片的名字在excel中：
2008-7-21-实习-001-泰国.jpg
2008-7-21-实习-002-泰国.jpg
2008-7-21-实习-005-金奈.jpg
2008-7-21-实习-009-金奈.jpg
2008-7-21-实习-013-金奈.jpg
2008-7-21-实习-014-金奈.jpg
2008-7-21-实习-017-金奈.jpg
2008-7-21-实习-018-金奈.jpg
2008-7-21-实习-023-金奈.jpg
2008-7-21-实习-027-金奈.jpg
2008-7-21-实习-035-金奈.jpg
2008-7-21-实习-041-金奈.jpg
2008-7-21-实习-001-班加罗尔.jpg
2008-7-21-实习-005-班加罗尔.jpg
2008-7-21-实习-007-班加罗尔.jpg
现在我想通过手动选择在金奈拍的一部分照片，然后执行代码，代码执行后能使实习后面那三个数字从001开始重新编程连续的一串序号，变成如下的一串命名：
2008-7-21-实习-001-金奈.jpg
2008-7-21-实习-002-金奈.jpg
2008-7-21-实习-003-金奈.jpg
2008-7-21-实习-004-金奈.jpg
2008-7-21-实习-005-金奈.jpg
2008-7-21-实习-006-金奈.jpg
2008-7-21-实习-007-金奈.jpg
2008-7-21-实习-008-金奈.jpg
2008-7-21-实习-009-金奈.jpg
2008-7-21-实习-010-金奈.jpg
如果在排序修改的同时，想对对源文件做同时的修改如何实现~~（在该列的后面一列记录着该图片的路径。例如：c:\photo\）

Answer 1

可以选择不连续的单元格，对于找不到 以当前单元格内容 命名的文件时，不更改单元格内容，并颜色提醒和输出到列表：
-----------------------
Private Sub iNameFile()
Dim c As Range, iNm$, iNmNew$, n&, iPath$, msg$, tmp
Selection.Interior.ColorIndex = xlNone
MsgBox "a"
For Each c In Selection.Cells
iPath = CStr(c.Offset(, 1))
iNm = CStr(c)
If Dir(iPath & iNm) <> "" Then
n = n + 1
tmp = Split(iNm, "-")
tmp(4) = Format(n, "000")
iNmNew = Join(tmp, "-")
Name iPath & iNm As iPath & iNmNew
c = iNmNew
Else
c.Interior.ColorIndex = 3
msg = msg & vbCrLf & c.Address(0, 0) & ": ‘" & iPath & iNm & "’"
End If
Next
If msg <> "" Then msg = vbCrLf & vbCrLf & "下列文件未找到：" & msg
MsgBox "ok! 成功重命名 " & n & " 个文件。" & msg
End Sub

Answer 2

Sub xxx()
Dim arr1, arr2(), x%, i%
x = Selection.Count
On Error Resume Next
ReDim arr2(1 To x, 1 To 2)
For Each str1 In Selection
i = i + 1
arr1 = Split(str1, "-")
arr1(4) = Format(i, "000")
arr2(i, 1) = Join(arr1, "-")
arr2(i, 2) = "D:\photo\"
Next
Selection.Resize(x, 2) = arr2
End Sub

追问

不是把后面的地址改掉，是根据地址，把源文件的命名也改掉！

追答

Sub xxx()
Dim arr1, arr2(), x%, i%, str1 As Range
x = Selection.Count
On Error Resume Next
ReDim arr2(1 To x, 1 To 1)
For Each str1 In Selection
i = i + 1
arr1 = Split(str1, "-")
arr1(4) = Format(i, "000")
arr2(i, 1) = Join(arr1, "-")
Name str1.Offset(0, 1) & str1 As str1.Offset(0, 1) & arr2(i, 1)
Next
Selection = arr2
End Sub

Answer 3

Sub YYY()
Dim arr
arr = Selection
For i = 1 To UBound(arr, 1)
arr(i, 1) = Replace(arr(i, 1), Mid(arr(i, 1), 14, 3), Format(i, "000"))
Next
Selection = arr
End Sub

Answer 4

这个进行排序就可以了，不清楚可以百度HI联系!

Answer 5

排序啊