[已解决]希望可以优化下

果冻的心

前两天论坛朋友帮忙实现的两个功能，实际操作比较麻烦，看看能不能将两个VBA整合以下最好优化下
文件夹有三个文件夹，分别为预算，PLM，结算单(为了方便上述文件夹名字只是举例)
实现原理：选择第一个文件夹（例如预算），选择第二个文件夹（例如PLM），选择第三个文件夹（例如结算单）。将第一个文件夹相关要求（VBA1实现的功能）和将第二个文件夹相关要求（VBA2实现的功能），复制到选择的第三个文件夹




预算里工作簿名是：聊城东昌府区周庄村2022-3-26_19-38-54（这个时间不一样有的是2022-1-7_9-25-40），PLM里是：聊城东昌府区周庄村基站施工费结算单，结算单里是：聊城东昌府区周庄村结算单，都包含聊城东昌府区周庄村，所以需要将这三个文件夹进行关联 实现

另外复制到结算单文件夹的表一工程结算下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

最佳答案

月排行榜 / 总排行榜

hasyh2008

2022-6-5 11:02

Option Explicit

跳转到最佳答案楼层

hasyh2008

再试试！！

果冻的心

hasyh2008 发表于 2022-6-4 22:57
再试试！！
Option Explicit
Dim MyFile As Object

有个小问题就是文件名字如果为聊城临清市铁路西邻小区22022-1-7_9-25-40命名的后应该为聊城临清市铁路西邻小区2，而实际是聊城临清市铁路西邻小区，能加个判断吗，我的想法是这个时间不管是2022-1-7_9-25-40还是2018-7-2_15-19-40还是2019-11-19_16-52-22，正常最前面这个时间都是4位（2022/2018/2019），如果出现聊城临清市铁路西邻小区22022-1-7_9-25-40这种情况前面肯定是大于4位数（22022）。大概就是判断这个是不是大于4位，大于4位的就只去掉后面4位（例如：聊城临清市铁路西邻小区1112022-1-7_9-25-40去掉后面四位：聊城临清市铁路西邻小区111）

hasyh2008

Option Explicit

hasyh2008

B3取值于PLM中的文件名，可把PLM里的文件命名为：聊城临清市铁路西邻小区2基站工程施工费结算单

hasyh2008

同时结算单中的文件也要命名为聊城临清市铁路西邻小区2结算单

果冻的心

hasyh2008 发表于 2022-6-5 11:21
同时结算单中的文件也要命名为聊城临清市铁路西邻小区2结算单

对偶，我想错复杂了，B3取决于plm或者结算单就ok拉，我应该是怕小区2022和小区22022，他们两个都按照小区来实现

果冻的心

hasyh2008 发表于 2022-6-5 11:02
Option Explicit
Dim MyFile As Object
Dim F1 As Object, Path1 As String

这个其实可以，把-10改成-8就可以了，多去了两位，当时没注意，感谢
Option Explicit
Dim MyFile As Object
Dim F1 As Object, Path1 As String
Dim F2 As Object, Path2 As String
Dim F3 As Object, Path3 As String
Dim Name
Dim FileName1(), FileName2(), FileName3()        '完整地址
Dim JName1$, JName2$, JName3$                    '简名
Dim K%, K1%, K2%, K3%, Rc%, Rc1%, Rc2%, Rc3%, Tim As Single
Dim Wb1 As Workbook, Wb2 As Workbook, Wb3 As Workbook
Sub 数据导入()
    On Error Resume Next    '// 发生错误，自动执行下一句，就是忽略错误
    Application.ScreenUpdating = False '//关闭屏幕刷新
    Application.DisplayAlerts = False '//关闭系统提示
    Application.EnableEvents = False  '//禁止触发其他事件
    Application.StatusBar = False   '关闭系统状态条
    Application.Interactive = False   '禁用鼠标、键盘，防干扰
    Tim = Timer
    Set MyFile = CreateObject("Scripting.FileSystemObject")
    Set F1 = Application.FileDialog(msoFileDialogFolderPicker)  '打开选择文件的对话框
    With F1  '如果选择了目录则提取目录的路径，否则退出程序
        If .Show = -1 Then Path1 = .SelectedItems(1) Else Exit Sub
    End With
    Set F2 = Application.FileDialog(msoFileDialogFolderPicker)
    With F2
        If .Show = -1 Then Path2 = .SelectedItems(1) Else Exit Sub
    End With
    Set F3 = Application.FileDialog(msoFileDialogFolderPicker)
    With F3
        If .Show = -1 Then Path3 = .SelectedItems(1) Else Exit Sub
    End With
    Name = Dir(Path1 & "\", 16)
    K = 0
    Do While Name <> ""
      If Name <> "." And Name <> ".." Then
        K = K + 1
        ReDim Preserve FileName1(1 To K)
        FileName1(K) = Path1 & "\" & Name
      End If
      Name = Dir
    Loop
    Name = Dir(Path2 & "\", 16)
    K = 0
    Do While Name <> ""
      If Name <> "." And Name <> ".." Then
        K = K + 1
        ReDim Preserve FileName2(1 To K)
        FileName2(K) = Path2 & "\" & Name
      End If
      Name = Dir
    Loop
    Name = Dir(Path3 & "\", 16)
    K = 0
    Do While Name <> ""
      If Name <> "." And Name <> ".." Then
        K = K + 1
        ReDim Preserve FileName3(1 To K)
        FileName3(K) = Path3 & "\" & Name
      End If
      Name = Dir
    Loop
    For K3 = 1 To UBound(FileName3)
        JName3 = MyFile.getbasename(FileName3(K3))
        Set Wb3 = GetObject(FileName3(K3))
        Rc3 = Wb3.Sheets("表三甲").Cells(Rows.Count, 1).End(xlUp).Row
        For K2 = 1 To UBound(FileName2)
            JName2 = MyFile.getbasename(FileName2(K2))
            JName2 = VBA.Left(JName2, VBA.Len(JName2) - 8)
            If InStr(JName3, JName2) > 0 Then
                Set Wb2 = GetObject(FileName2(K2))
                With Wb3.Sheets("表三甲")
                    Rc2 = Wb2.Sheets("表三甲").Cells(Rows.Count, 1).End(xlUp).Row
                    Rc = Rc2 + 3 - Rc3
                    If Rc < 0 Then
                        .Rows(7).Resize(0 - Rc).Delete
                    ElseIf Rc > 0 Then
                        .Rows(Rc3).Offset(-2 - Rc).Resize(Rc).Insert
                        .Range("H7:I" & Rc2).FillDown
                    End If
                    Wb2.Sheets("表三甲").Range("A6:D" & Rc2 - 1).Copy .Range("A7")
                    Wb2.Sheets("表三甲").Range("F6:H" & Rc2 - 1).Copy .Range("E7")
                    Wb2.Sheets("表三甲").Range("M6:M" & Rc2 - 1).Copy .Range("J7")
                End With
                With Wb3.Sheets("表一工程结算")
                    .Range("B3") = JName2
                    .Range("E18") = "=IF(E17>=95,E16,E16*0.9+E16*0.1*(E17/95))"
                    .Range("J1") = "原表数额：" & Wb2.Sheets("表一工程结算").Range("E18")
                    .Range("K1") = "和原表差额："
                    .Range("L1") = Application.Round(.Range("E18") - Wb2.Sheets("表一工程结算").Range("E18"), 2)
                    .Range("E18") = "=IF(E17>=95,E16,E16*0.9+E16*0.1*(E17/95))-L1"
                    .Columns("J:L").ColumnWidth = 0
                End With
                Wb2.Windows(1).Visible = True
                Wb2.Close False
                GoTo 100
            End If
        Next K2
100:
        For K1 = 1 To UBound(FileName1)
            JName1 = MyFile.getbasename(FileName1(K1))
            JName1 = TQ(JName1, 3)
            If InStr(JName3, JName1) > 0 Then
                Set Wb1 = GetObject(FileName1(K1))
                Rc1 = Wb1.Sheets("物资领用表").Cells(Wb1.Sheets("物资领用表").Rows.Count, 1).End(xlUp).Row
                Wb1.Sheets("物资领用表").Range("B4:F" & Rc1).Copy Wb3.Sheets("表四材料").Range("B4")
                Wb3.Sheets("表四材料").Rows(Rc1 + 1).Resize(1000).Clear

                Wb1.Windows(1).Visible = True
                Wb1.Close False
                GoTo 200
            End If
        Next K1
200:
        Wb3.Windows(1).Visible = True
        Wb3.Close True
    Next K3
    Application.Quit
    MsgBox "运行时间为：" & Format(Timer - Tim, "0.00秒")
    Set F1 = Nothing
    Set F2 = Nothing
    Set F3 = Nothing
    Set Wb1 = Nothing
    Set Wb2 = Nothing
    Set Wb3 = Nothing
    Set MyFile = Nothing
    Application.StatusBar = True   '恢复系统状态条
    Application.EnableEvents = True  '//恢复触发其他事件
    Application.ScreenUpdating = True '//恢复屏幕刷新
    Application.DisplayAlerts = True '//恢复系统提示
    Application.Interactive = True    '启用鼠标键盘
End Sub

果冻的心

hasyh2008 发表于 2022-6-4 22:57
再试试！！