VBA通过一定规律匹配后另存为文件
Posted liuxiaoddd
tags:
篇首语：本文由小常识网(cha138.com)小编为大家整理，主要介绍了VBA通过一定规律匹配后另存为文件相关的知识，希望对你有一定的参考价值。
下载下来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
以上是关于VBA通过一定规律匹配后另存为文件的主要内容，如果未能解决你的问题，请参考以下文章