求助：多簿单表合并

dcy44933

跪求大神帮忙解决，具体见附件，谢谢！！

iwangyi

合并功能如下

Sub CC()
N = 3
p = ThisWorkbook.Path & "\"
f = Dir(p & "*.xl*")
Do While f <> ""
If f <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(p & f)
For Each SH In Sheets
X = SH.[B65536].End(3).Row
N = [B65536].End(3).Row + 1
SH.Range("a3:j" & X).Copy Cells(N, 1)
Next
wb.Close
End If
f = Dir
Loop
End Sub

iwangyi

删除功能如下Sub
SC()
Range("A1").CurrentRegion.Offset(3).Delete
End Sub

iwangyi

查询功能，下班了没时间

lsc900707

对别人的帮助要及时反馈!

dcy44933

lsc900707 发表于 2018-9-13 18:37
对别人的帮助要及时反馈!

谢谢！刚看到的

dcy44933

lsc900707 发表于 2018-9-13 18:37
对别人的帮助要及时反馈!

我试了一下，没有数据过来。还烦帮我看看是那有问题，谢谢老师！

lsc900707

dcy44933 发表于 2018-9-13 19:57
我试了一下，没有数据过来。还烦帮我看看是那有问题，谢谢老师！

有的工作表有密码保护，请先去除密码后测试“合并”代码：
Sub test()
    Dim brr(1 To 100000, 1 To 10)
    p = ThisWorkbook.Path & "\"
    f = Dir(p & "*.xlsx")
    Application.ScreenUpdating = False
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            Set sht = Workbooks.Open(p & f).Sheets(1)
            Arr = sht.[a1].CurrentRegion
            Workbooks(f).Close False
            For i = 3 To UBound(Arr)
                If Len(Arr(i, 1)) Then
                    m = m + 1
                    For j = 1 To 10
                        brr(m, j) = Arr(i, j)
                    Next
                End If
            Next
        End If
        f = Dir
    Loop
    Set sht = Nothing
    If m Then
        Range("a4:j" & Rows.Count).ClearContents
        [a4].Resize(m, 10) = brr
    End If
    Application.ScreenUpdating = True
    MsgBox "合并完成！"
End Sub

dcy44933

brr(m, j) = Arr(i, j),运用到这里就不行了

dcy44933

iwangyi 发表于 2018-9-13 17:57
删除功能如下Sub
SC()
Range("A1").CurrentRegion.Offset(3).Delete

谢谢你的帮助！我测试了，好像不照，提取不了数据。还请有时间帮我看看，再次谢谢！