优化功能
前两天论坛朋友帮忙实现的两个功能，实际操作比较麻烦，看看能不能将两个VBA整合以下最好优化下文件夹有三个文件夹，分别为预算，PLM，结算单(为了方便上述文件夹名字只是举例)
实现原理：选择第一个文件夹（例如预算），选择第二个文件夹（例如PLM），选择第三个文件夹（例如结算单）。将第一个文件夹相关要求（VBA1实现的功能）和将第二个文件夹相关要求（VBA2实现的功能），复制到选择的第三个文件夹
例如
优化.zip
(575.55 KB)
另外复制到结算单文件夹的表一工程结算下B3文件名也要修改，原来VBA2是将工作簿的名字应用到表一工程结算下B3，现在需要去掉结算单三个字后进行应用
VBA1：
Option Explicit
Sub 数据导入()
On Error Resume Next '// 发生错误，自动执行下一句，就是忽略错误
Application.ScreenUpdating = False '//关闭屏幕刷新
Application.DisplayAlerts = False '//关闭系统提示
Application.EnableEvents = False '//禁止触发其他事件
Application.StatusBar = False '关闭系统状态条
Application.Interactive = False '禁用鼠标、键盘，防干扰
Dim MyFile As Object
Dim AFileName As Variant
Dim BFileName As Variant
Dim AWb As Workbook
Dim BWb As Workbook
Dim APath$, AMyName$, BMyName$
Dim ARc%, BRc%, Rc%, K%, AK%, BK%, AStr$, BStr$
Dim Tim As Single
Tim = Timer
Set MyFile = CreateObject("Scripting.FileSystemObject")
AFileName = Application.GetOpenFilename("EXCEL文件,*.xls*, 所有文件, *.*", 1, Title:="请选择需要导入的源表格：", MultiSelect:=True)
'修改文件名称
For AK = 1 To UBound(AFileName)
AStr = MyFile.Getfile(AFileName(AK)).Name '名称
APath = MyFile.Getfile(AFileName(AK)).ParentFolder 'Path
If VBA.Left(AStr, 1) <> "A" Then
Name APath & "\" & AStr As APath & "\A" & AStr
AFileName(AK) = APath & "\A" & AStr
End If
Next AK
BFileName = Application.GetOpenFilename("EXCEL文件,*.xls*, 所有文件, *.*", 1, Title:="请选择需要导入数据的表格：", MultiSelect:=True)
For BK = 1 To UBound(BFileName)
BStr = MyFile.Getfile(BFileName(BK)).Name
BMyName = MyFile.getbasename(BFileName(BK))
Set BWb = GetObject(BFileName(BK))
For AK = 1 To UBound(AFileName)
AMyName = MyFile.getbasename(AFileName(AK))
If AMyName = "A" & BMyName Then
Set AWb = GetObject(AFileName(AK))
ARc = AWb.Sheets("物资领用表").Cells(AWb.Sheets("物资领用表").Rows.Count, 1).End(xlUp).Row
AWb.Sheets("物资领用表").Range("B4:F" & ARc).Copy BWb.Sheets("表四材料").Range("B4")
BWb.Sheets("表四材料").Rows(ARc + 1).Resize(1000).Clear
BWb.Sheets("表一工程结算").Range("B3") = MyFile.getbasename(BFileName(BK))
AWb.Close False
GoTo 100
End If
100:
Next AK
With BWb
.Windows(1).Visible = True
.Save
.Close False
End With
Next BK
'恢复文件名
For AK = 1 To UBound(AFileName)
AStr = MyFile.Getfile(AFileName(AK)).Name '名称
If VBA.Left(AStr, 1) = "A" Then
Name APath & "\" & AStr As APath & "\" & VBA.Right(AStr, Len(AStr) - 1)
End If
Next AK
With ThisWorkbook
.Windows(1).Visible = True
.Save
End With
' Application.Quit
MsgBox Format(Timer - Tim, "0.00")
Set MyFile = Nothing
Set AWb = Nothing
Set BWb = Nothing
Application.StatusBar = True '恢复系统状态条
Application.EnableEvents = True '//恢复触发其他事件
Application.ScreenUpdating = True '//恢复屏幕刷新
Application.DisplayAlerts = True '//恢复系统提示
Application.Interactive = True '启用鼠标键盘
End Sub
VBA1：
Option Explicit
Sub 数据导入()
On Error Resume Next '// 发生错误，自动执行下一句，就是忽略错误
Application.ScreenUpdating = False '//关闭屏幕刷新
Application.DisplayAlerts = False '//关闭系统提示
Application.EnableEvents = False '//禁止触发其他事件
Application.StatusBar = False '关闭系统状态条
Application.Interactive = False '禁用鼠标、键盘，防干扰
Dim MyFile As Object
Dim AFileName As Variant
Dim BFileName As Variant
Dim AWb As Workbook
Dim BWb As Workbook
Dim APath$
Dim ARc%, BRc%, Rc%, K%, AK%, BK%, AStr$, BStr$
Dim Tim As Single
Tim = Timer
Set MyFile = CreateObject("Scripting.FileSystemObject")
AFileName = Application.GetOpenFilename("EXCEL文件,*.xls*, 所有文件, *.*", 1, Title:="请选择需要导入的源表格：", MultiSelect:=True)
'修改文件名称
For AK = 1 To UBound(AFileName)
AStr = MyFile.Getfile(AFileName(AK)).Name '名称
APath = MyFile.Getfile(AFileName(AK)).ParentFolder 'Path
If VBA.Left(AStr, 1) <> "A" Then
Name APath & "\" & AStr As APath & "\A" & AStr
AFileName(AK) = APath & "\A" & AStr
End If
Next AK
BFileName = Application.GetOpenFilename("EXCEL文件,*.xls*, 所有文件, *.*", 1, Title:="请选择需要导入数据的表格：", MultiSelect:=True)
For BK = 1 To UBound(BFileName)
BStr = MyFile.Getfile(BFileName(BK)).Name
Set BWb = GetObject(BFileName(BK))
BRc = BWb.Sheets("表三甲").Cells(Rows.Count, 1).End(xlUp).Row
For AK = 1 To UBound(AFileName)
AStr = MyFile.Getfile(AFileName(AK)).Name
If AStr = "A" & BStr Then
Set AWb = GetObject(AFileName(AK))
With BWb.Sheets("表三甲")
ARc = AWb.Sheets("表三甲").Cells(Rows.Count, 1).End(xlUp).Row
Rc = ARc + 3 - BRc
If Rc < 0 Then
.Rows(7).Resize(0 - Rc).Delete
ElseIf Rc > 0 Then
.Rows(BRc).Offset(-2 - Rc).Resize(Rc).Insert
.Range("H7:I" & ARc).FillDown
End If
AWb.Sheets("表三甲").Range("A6:D" & ARc - 1).Copy .Range("A7")
AWb.Sheets("表三甲").Range("F6:H" & ARc - 1).Copy .Range("E7")
AWb.Sheets("表三甲").Range("M6:M" & ARc - 1).Copy .Range("J7")
End With
With BWb.Sheets("表一工程结算")
.Range("B3") = MyFile.getbasename(BFileName(BK))
.Range("E18") = "=IF(E17>=95,E16,E16*0.9+E16*0.1*(E17/95))"
.Range("J1") = "原表数额：" & AWb.Sheets("表一工程结算").Range("E18")
.Range("K1") = "和原表差额：" & Application.Round(.Range("E18") - AWb.Sheets("表一工程结算").Range("E18"), 2)
End With
AWb.Close False
GoTo 100
End If
100:
Next AK
With BWb
.Windows(1).Visible = True
.Save
.Close False
End With
Next BK
'恢复文件名
For AK = 1 To UBound(AFileName)
AStr = MyFile.Getfile(AFileName(AK)).Name '名称
If VBA.Left(AStr, 1) = "A" Then
Name APath & "\" & AStr As APath & "\" & VBA.Right(AStr, Len(AStr) - 1)
End If
Next AK
With ThisWorkbook
.Windows(1).Visible = True
.Save
End With
' Application.Quit
MsgBox Format(Timer - Tim, "0.00")
Set MyFile = Nothing
Set AWb = Nothing
Set BWb = Nothing
Application.StatusBar = True '恢复系统状态条
Application.EnableEvents = True '//恢复触发其他事件
Application.ScreenUpdating = True '//恢复屏幕刷新
Application.DisplayAlerts = True '//恢复系统提示
Application.Interactive = True '启用鼠标键盘
End Sub
[此贴子已经被作者于2022-6-3 17:21编辑过]
