多EXCEL文档含保护密码如何取数汇总

teshia

有十家店，将工资表发过来，要汇总发给总公司
已经实行汇总功能但由于每个月表格人员均有变动，这个月是127行，下个月可能135行……
月份工资汇总表.rar (158.33 KB, 下载次数: 24)

2018-4-16 23:03 上传

点击文件名下载附件

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、或者不用我这种方式，直接遍历读取值？

蓝桥玄霜

没有附件不能测试代码。
建议上传Excel表格附件来说明问题。

LMY123

ADO同名工作表分开合并

teshia

蓝桥玄霜 发表于 2018-4-17 08:46
没有附件不能测试代码。
建议上传Excel表格附件来说明问题。

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

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

opiona

汇总分表到总表，通用代码

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

复制代码

opiona

完整代码 见附件：   多分表汇总通用代码-opiona14885553.rar (452.95 KB, 下载次数: 34)

2018-4-20 10:07 上传

点击文件名下载附件

可自适应：文件个数，标题，行数的

lsc900707

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

teshia

lsc900707 发表于 2018-4-20 11:03
Sub tt618()
    p = ThisWorkbook.Path & "\工资表\"
    f = Dir(p & "*.xls*")

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

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

lsc900707

teshia 发表于 2018-4-21 08:36
我稍后来仔细研究研究学习学习，太棒了

j赋值到6 ，

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

lsc900707

teshia 发表于 2018-4-21 08:36
我稍后来仔细研究研究学习学习，太棒了

j赋值到6 ，

要不也加上On Error Resume Next