VBA通过一定规律匹配后另存为文件_vba代码另存为-优快云博客

本文链接：https://blog.youkuaiyun.com/liuxiaoddd/article/details/120996536

该代码段是一个VBA宏，用于遍历指定路径下的所有Excel文件（除特定文件外），通过查找匹配的机构名称在机构对照表中获取对应的机构号。然后，将工作簿打开，读取其名称，根据机构号重新命名并保存为新文件。整个过程实现了自动化文件管理和重命名功能。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

下载下来80多个文件只有中文机构名，通过机构对照表匹配对应的机构号，然后用机构号来另存文件。

运行前：

运行后：

机构表：

代码附上：

Sub GetAll()
Dim MyPath$, MyName$, NewName$, orgname$, orgno$
Dim N%, POS%, a%

Dim MyFile
Dim count!

N = 1
POS = 0
a = 1

ActiveWorkbook.Sheets(1).Columns(1).Clear
ActiveWorkbook.Sheets(1).Columns(2).Clear
MyPath = ThisWorkbook.Path & "\"
MyName = Dir(MyPath & "*.xls", vbDirectory)
Do While MyName <> ""
orgname = ""
orgno = ""
a = 1
POS = 0
If MyName <> "鼬.xls" Then


'从另一个sheet页获取要匹配的机构名称和机构号
POS = InStr(MyName, "07")
orgname = Mid(MyName, 1, POS - 1)
Do While a < 80
If ActiveWorkbook.Sheets(5).Cells(a, 1).Value = orgname Then
orgno = ActiveWorkbook.Sheets(5).Cells(a, 2)
End If
a = a + 1
Loop
Range("A" & N) = orgname
Range("B" & N) = orgno

Workbooks.Open Filename:=MyPath & MyName
sname = ActiveSheet.Name


'另存为文件
N = N + 1

If orgno <> "" Then
'ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & orgno & "_201906_07计算表（附表六）" & ".xls"
ActiveWorkbook.SaveCopyAs Filename:=ThisWorkbook.Path & "\" & orgno & "_201912_07计算表（附表六）" & ".xls"
End If

ActiveWorkbook.Close savechanges:=True
MyName = Dir

Else
MyName = Dir
End If

Loop
Application.ScreenUpdating = False

End Sub