[已解决]我又来求助啦，大佬给搞一下吧！感谢

果冻的心 · 发表于 2022-5-30 20:03

hasyh2008 发表于 2022-5-30 19:45
只能这样处理了，单元格中不可能即用函数公式又用VBa变量

Sub 数据导入()

好的，那个不是必须，麻烦在改下这个吧，在应该这个基础上改下就行，还是可以自动选取文件夹，复制A文件到B文件对应位置去掉多余行，感谢

hasyh2008 · 发表于 2022-5-30 20:51

预算表格要和结算的表格采用同一种格式，也要用xlsx格式

果冻的心 · 发表于 2022-5-30 21:31

hasyh2008 发表于 2022-5-30 20:51
预算表格要和结算的表格采用同一种格式，也要用xlsx格式

我把A4改成B4，但是A列多余的项目编号如何删除？

hasyh2008 · 发表于 2022-5-30 21:47

本帖最后由 hasyh2008 于 2022-5-31 14:14 编辑

2222222

果冻的心 · 发表于 2022-5-31 10:32

本帖最后由果冻的心于 2022-5-31 11:40 编辑

hasyh2008 发表于 2022-5-30 21:47
Sub 数据导入()
On Error Resume Next '// 发生错误，自动执行下一句，就是忽略错误
Applicat ...

可不可以加一个将预算xls格式改成xlsx格式，在进行相应复制，这样就不用手动改了

还有我运行后表四材料为空是怎末回事

hasyh2008 · 发表于 2022-5-31 11:54

本帖最后由 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

果冻的心 · 发表于 2022-6-1 08:47

hasyh2008 发表于 2022-5-31 11:54
再试试

Sub 数据导入()

试了下可以了，为啥测试文件的时候正常，实际用于其他文件时会发生错误

hasyh2008 · 发表于 2022-6-1 09:49

本帖最后由 hasyh2008 于 2022-6-1 15:01 编辑

果冻的心发表于 2022-6-1 08:47
试了下可以了，为啥测试文件的时候正常，实际用于其他文件时会发生错误

在我电脑中测试没问题
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:F1000").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

hasyh2008 · 发表于 2022-6-2 10:21

如果还不行的话，可以批量修改文件格式，再试试。

Sub 批量改xls为xlsx()
  On Error Resume Next '// 发生错误，自动执行下一句，就是忽略错误
  Application.ScreenUpdating = False '//关闭屏幕刷新
  Application.DisplayAlerts = False '//关闭系统提示
  Dim MyFile As Object
  Dim FileName()
  Dim Wb As Workbook
  Dim StrName$, Name$, K%
  Set MyFile = CreateObject("Scripting.FileSystemObject")
  FileName = Application.GetOpenFilename("EXCEL97-2003文件,*.xls", Title:="请选择需要更改格式的xls文件：", MultiSelect:=True)
  For K = 1 To UBound(FileName)
Set Wb = GetObject(FileName(K))
StrName = FileName(K) & "x"
Name = MyFile.getbasename(FileName(K)) & "x"
With Wb
   .SaveAs FileName:=StrName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
   .Windows(1).Visible = True
   .Close True
End With
MyFile.DeleteFile FileName(K)
Workbooks(Name).Windows(1).Visible = True
Workbooks(Name).Close True

  Next K
  With ThisWorkbook
.Windows(1).Visible = True
  End With
  Application.Quit
  Set Wb = Nothing
  Set MyFile = Nothing
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

果冻的心 · 发表于 2022-6-2 11:40

hasyh2008 发表于 2022-6-2 10:21
如果还不行的话，可以批量修改文件格式，再试试。

Sub 批量改xls为xlsx()

你给的26楼和28楼都可以啦，感谢大佬

		自动登录	找回密码
密码			注册