| 网站首页 | 业界新闻 | 小组 | 威客 | 人才 | 下载频道 | 博客 | 代码贴 | 在线编程 | 编程论坛
欢迎加入我们,一同切磋技术
用户名:   
 
密 码:  
共有 1139 人关注过本帖
标题:优化功能
只看楼主 加入收藏
果冻的心
Rank: 1
等 级:新手上路
帖 子:1
专家分:0
注 册:2022-6-3
收藏
 问题点数:0 回复次数:0 
优化功能
前两天论坛朋友帮忙实现的两个功能,实际操作比较麻烦,看看能不能将两个VBA整合以下最好优化下
文件夹有三个文件夹,分别为预算,PLM,结算单(为了方便上述文件夹名字只是举例)
实现原理:选择第一个文件夹(例如预算),选择第二个文件夹(例如PLM),选择第三个文件夹(例如结算单)。将第一个文件夹相关要求(VBA1实现的功能)和将第二个文件夹相关要求(VBA2实现的功能),复制到选择的第三个文件夹




例如
优化.zip (575.55 KB)
预算里工作簿名是:聊城东昌府区周庄村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


[此贴子已经被作者于2022-6-3 17:21编辑过]

搜索更多相关主题的帖子: False If Dim Application End 
2022-06-03 17:19
快速回复:优化功能
数据加载中...
 
   



关于我们 | 广告合作 | 编程中国 | 清除Cookies | TOP | 手机版

编程中国 版权所有,并保留所有权利。
Powered by Discuz, Processed in 0.032249 second(s), 9 queries.
Copyright©2004-2024, BCCN.NET, All Rights Reserved