|
本帖最后由 hasyh2008 于 2022-5-31 12:07 编辑
再试试
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 |
|