ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 2259|回复: 13

[求助] 多EXCEL文档含保护密码如何取数汇总

[复制链接]

TA的精华主题

TA的得分主题

发表于 2018-4-16 22:47 | 显示全部楼层 |阅读模式
本帖最后由 teshia 于 2018-4-16 23:04 编辑

有十家店,将工资表发过来,要汇总发给总公司
已经实行汇总功能但由于每个月表格人员均有变动,这个月是127行,下个月可能135行……
月份工资汇总表.rar (158.33 KB, 下载次数: 24)
  1. Sub tt618()
  2.     Dim MyPath$, MyName$, Arr, i%, j%, Brr, ws As Workbook
  3.     MyPath = ThisWorkbook.Path & "\工资表"
  4.     MyName = Dir(MyPath & "*.xls")
  5.     Union([M3:Q127], [S3:V127], [X3:Y127], [AA3:AB127]).ClearContents
  6. '    Union([M3:Z127], [AA3:AB150]).ClearContents
  7.     Arr = Range("M3:AB127")
  8.     Application.ScreenUpdating = False
  9.     Do While MyName <> ""
  10.         If MyName <> ThisWorkbook.Name Then
  11.             Set wb = GetObject(MyPath & MyName)
  12.             On Error Resume Next
  13.             If wb.Sheets(2).Name = "工资表" Then
  14.             Brr = wb.Sheets("工资表").Range("M3:AB127")
  15. '            MsgBox wb.Sheets(2).Name
  16.             For i = 1 To UBound(Brr)
  17.                 For j = 1 To UBound(Brr, 2)
  18.                     If Brr(i, j) <> "" Then
  19. '                    If cstr(brr(i, j)) And brr(i, j) <> "" Then
  20.                         If Brr(i, j) = "" Then
  21.                             Arr(i, j) = Val(Brr(i, j))
  22.                         ElseIf IsNumeric(Brr(i, j)) Then
  23.                             Arr(i, j) = Val(Arr(i, j)) + Val(Brr(i, j))
  24.                         Else
  25.                             Arr(i, j) = CStr(Arr(i, j)) + CStr(Brr(i, j))
  26.                         End If
  27.                     End If
  28.                 Next
  29.         Next
  30.         wb.Close False
  31.         End If
  32.         End If
  33.         MyName = Dir
  34.     Loop
  35.     Range("M3:AB127") = Arr
  36.     Application.ScreenUpdating = True
  37. End Sub
复制代码



我每个月都要 替换一下行数
1、如何将127行,变成变量,在不知道保护密码的前提下
2、或者不用我这种方式,直接遍历读取值?


TA的精华主题

TA的得分主题

发表于 2018-4-17 08:46 | 显示全部楼层
没有附件不能测试代码。
建议上传Excel表格附件来说明问题。

TA的精华主题

TA的得分主题

发表于 2018-4-17 08:50 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-4-19 22:25 | 显示全部楼层
蓝桥玄霜 发表于 2018-4-17 08:46
没有附件不能测试代码。
建议上传Excel表格附件来说明问题。

版主好,有附件。
附件中是四月 三家店,人员占的是第3行到127行
就是到了 五月,可能不同店铺中间会有离职,和新入员工,可能会变成第3行到130行

我的代码中,全部是固定的行数,想用变量来表示
Union([M3:Q127], [S3:V127], [X3:Y127], [AA3:AB127]).ClearContents
Arr = Range("M3:AB127")

TA的精华主题

TA的得分主题

发表于 2018-4-20 10:05 | 显示全部楼层
汇总分表到总表,通用代码

  1.     BTROW = 2 '//标题所在行,假设汇总表和分表都相同
  2.     NameSheet = "工资表"   '//数据所在工作表名,假设汇总表和分表都相同
  3.    
  4.     Rem 清空汇总表原有数据,保留标题
  5.     Set SH0 = Sheets(NameSheet)
  6.     SH0.Range("A" & BTROW + 1 & ":HZ65536").ClearContents
  7.     Rem 自动根据汇总表标题,组织查询标题,汇总表标题可增减,只要分表中存在此标题即可
  8.     StrBT = ""
  9.     For ICOL = 1 To SH0.Range("HZ" & BTROW).End(xlToLeft).Column
  10.         If StrBT <> "" Then StrBT = StrBT & ","
  11.         If Len(SH0.Cells(BTROW, ICOL).Value) > 0 Then
  12.             StrBT = StrBT & "[" & SH0.Cells(BTROW, ICOL).Value & "]"
  13.         Else
  14.             Rem 标题之间可能的空白列
  15.             StrBT = StrBT & "NULL AS [空白列_" & ICOL & "]"
  16.         End If
  17.     Next
  18.     Rem 获取文件清单
  19.     FileArr = FileAllArr(ThisWorkbook.Path, "*.xls?", ThisWorkbook.Name, True, False)
  20.     If FileArr(0) <> "" Then  '//如果文件清单 不是空白的
  21.         ICOUNT = UBound(FileArr) + 1
  22.         Rem 遍历每个分表文件
  23.         For I = 0 To ICOUNT - 1
  24.             Rem  提示信息,在状态栏显示
  25.             Application.StatusBar = "文件总数:" & ICOUNT & " 当前是第:" & I + 1 & " 当前提取的文件是:" & GetPathFromFileName(FileArr(I), True)  '
  26.             DoEvents
  27.             Rem 查询数据,结果为数组
  28.             Str_coon = "HDR=yes';Data Source =" & FileArr(I)    '//OFFICE2003,2007 通用
  29.             StrSQL = "SELECT " & StrBT
  30.             StrSQL = StrSQL & ",'" & GetPathFromFileName(FileArr(I)) & "' AS  工作簿"   '//不需要文件名,可删除此行
  31.             StrSQL = StrSQL & " FROM [" & NameSheet & "$A" & BTROW & ":HZ]"
  32.             SQLARR = GET_SQL_To_Arr(StrSQL, Str_coon, False)
  33.             Rem 粘贴数据
  34.             LASTROW = SH0.Range("A65536").End(3).Row + 1
  35.             SH0.Range("A" & LASTROW).Resize(UBound(SQLARR, 1) + 1, UBound(SQLARR, 2) + 1) = SQLARR '//(0 TO X)的数组行列都要+1,(1 TO X) 的不要
  36.         Next I
  37.     End If
复制代码

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2018-4-20 10:07 | 显示全部楼层
完整代码 见附件:   多分表汇总通用代码-opiona14885553.rar (452.95 KB, 下载次数: 33)
可自适应:文件个数,标题,行数的

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2018-4-20 11:03 | 显示全部楼层
本帖最后由 lsc900707 于 2018-4-20 15:42 编辑
teshia 发表于 2018-4-19 22:25
版主好,有附件。
附件中是四月 三家店,人员占的是第3行到127行
就是到了 五月,可能不同店铺中间会有 ...

Sub tt618()
    p = ThisWorkbook.Path & "\工资表\"
    f = Dir(p & "*.xls*")
    r = Cells(Rows.Count, 6).End(3).Row
    Union(Range("M3:Q" & r), Range("S3:V" & r), Range("X3:Y" & r), Range("AA3:AB" & r)).ClearContents
    Arr = Range("M3:AB" & r)
    Application.ScreenUpdating = False
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            Set wb = GetObject(p & f)
            With wb.Sheets(2)
                 .Protect AllowFiltering:=True
                 .Unprotect
                 r = .Cells(.Rows.Count, 6).End(3).Row
                 Brr = .Range("M3:AB" & r)
            End With
            For i = 1 To UBound(Brr)
                For j = 1 To UBound(Brr, 2)
                    If Brr(i, j) <> "" Then
                        If CStr(Brr(i, j)) And Brr(i, j) <> "" Then
                            If Brr(i, j) = "" Then
                                Arr(i, j) = Val(Brr(i, j))
                            ElseIf IsNumeric(Brr(i, j)) Then
                                Arr(i, j) = Val(Arr(i, j)) + Val(Brr(i, j))
                            Else
                                Arr(i, j) = CStr(Arr(i, j)) + CStr(Brr(i, j))
                            End If
                        End If
                    End If
                Next
            Next
            wb.Close False
        End If
        f = Dir
    Loop
    Range("M3:AB" & r) = Arr
    Application.ScreenUpdating = True
End Sub

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-4-21 08:36 | 显示全部楼层
lsc900707 发表于 2018-4-20 11:03
Sub tt618()
    p = ThisWorkbook.Path & "\工资表\"
    f = Dir(p & "*.xls*")

我稍后来仔细研究研究学习学习,太棒了

j赋值到6 ,
运行时错误‘‘13’’,类型不匹配

TA的精华主题

TA的得分主题

发表于 2018-4-21 08:59 | 显示全部楼层
teshia 发表于 2018-4-21 08:36
我稍后来仔细研究研究学习学习,太棒了

j赋值到6 ,

你原先的程序是否就有问题?我只是修改了变量。

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2018-4-21 09:01 | 显示全部楼层
teshia 发表于 2018-4-21 08:36
我稍后来仔细研究研究学习学习,太棒了

j赋值到6 ,

要不也加上On Error Resume Next

评分

1

查看全部评分

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 23:21 , Processed in 0.063104 second(s), 18 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

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