设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 我又来求助啦，大佬给搞一下吧！感谢
数据透视表40+个常用小技巧，让你一次学会！
123下一页
返回列表 发新帖
查看: 2521|回复: 29

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

[复制链接]
发表于 2022-5-17 15:31 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
3学分
本帖最后由 果冻的心 于 2022-5-19 14:11 编辑

将A文件夹下的工作簿表表三甲框选的三部分分别复制到B文件夹对应文件名下表三甲对应位置，然后将下面的多余的行去掉，然后将做好得到表一结算单e18单元格数值和A文件原文件比较，如果有差值就在此单元格加上或者减去对应差值(在原公式状态下加减差值)，同时将B文件下的工作簿文件名应用到表一结算单B3单元格





能够自己选择文件夹
最佳答案
月排行榜 / 总排行榜
hasyh2008
2022-5-17 15:31
本帖最后由 hasyh2008 于 2022-5-30 11:36 编辑

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%, I%, X%, Y%, 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
1.需要复制.png
2.复制到B对应文件名.png
3.这部分去除.png
4.png
加减差值.png
文件名应用B3.png
微信图片_20220516173919.png

需解决.zip

703.17 KB, 下载次数: 37

最佳答案

hasyh2008

查看完整内容

Sub 数据导入() On Error Resume Next '// 发生错误，自动执行下一句，就是忽略错误 Application.ScreenUpdating = False '//关闭屏幕刷新 Application.DisplayAlerts = False '//关闭系统提示 Application.EnableEvents = False '//禁止触发其他事件 Application.StatusBar = False '关闭系统状态条 Application.Interactive = False '禁用鼠标、键盘，防干扰 Dim MyFile As Object ...
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
发表于 2022-5-17 15:31 | 显示全部楼层    本楼为最佳答案   
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 hasyh2008 于 2022-5-30 11:36 编辑

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%, I%, X%, Y%, 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

需解决(20220530).rar

359.25 KB, 下载次数: 4
回复

使用道具 举报

 楼主| 发表于 2022-5-17 21:00 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
本帖最后由 果冻的心 于 2022-5-20 08:38 编辑

回复

使用道具 举报

 楼主| 发表于 2022-5-18 21:28 | 显示全部楼层
本帖最后由 果冻的心 于 2022-5-20 05:48 编辑

有没有大佬搞下
回复

使用道具 举报

 楼主| 发表于 2022-5-20 12:51 | 显示全部楼层
1
回复

使用道具 举报

 楼主| 发表于 2022-5-20 22:38 | 显示全部楼层
2
回复

使用道具 举报

 楼主| 发表于 2022-5-21 23:09 | 显示全部楼层
3
回复

使用道具 举报

 楼主| 发表于 2022-5-24 21:17 | 显示全部楼层
4
回复

使用道具 举报

发表于 2022-5-25 09:52 | 显示全部楼层
你这可不是一会能搞定的
回复

使用道具 举报

 楼主| 发表于 2022-5-25 16:56 | 显示全部楼层
lh6972338 发表于 2022-5-25 09:52
你这可不是一会能搞定的


回复

使用道具 举报

下一页 »
123下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-4-19 15:05 , Processed in 0.442762 second(s), 9 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表