求助：多工作簿特定工作表特定区域提取数据

一壶鱼

多工作簿特定工作表特定区域提取数据，已上传附件

一壶鱼

求助，大佬们，因为每个工作簿里E9是合并的单元格，所以对应的行数不一样，选定区域我不知道怎么选定

ykcbf1100

你这种合并单元格造成了后期数据处理的麻烦。

发哥76

给你硬凑了一个，试一下：
Sub test()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim Mpath$, Mfile$, i%, n%, copyRange As Range, pasteRange As Range, E9r%, r1%, r2%
    Mpath = ThisWorkbook.Path & "\"
    Mfile = Dir(Mpath & "*.xls")
    r = Application.Max(Cells(Rows.Count, 2).End(xlUp).Row, 8)
    If Cells(r, 2).MergeCells Then
        Rows("8:" & Cells(r, 2).MergeArea.Row + Cells(r, 2).MergeArea.Rows.Count - 1).Delete
    Else
        Rows("8:" & Cells(r, 2).Row).Delete
    End If
    r2 = 7
    Do
        If Mfile <> ThisWorkbook.Name Then
            n = n + 1
            r = r2 + 1
            Set wb = GetObject(Mpath & Mfile)
            Set sh = wb.Sheets("分户表")
            Cells(r, 2) = n
            Cells(r, 3) = sh.Range("l2")
            Cells(r, 4) = sh.Range("c4")
            Cells(r, 5) = sh.Range("i4")
            E9r = sh.Range("e9").MergeArea.Row + sh.Range("e9").MergeArea.Rows.Count - 1
            Set copyRange = sh.Range("a9:l" & E9r)
            Set pasteRange = Range("f" & r)
            copyRange.Copy
            pasteRange.PasteSpecial Paste:=xlPasteAll
            Application.CutCopyMode = False
            wb.Close False
        End If
        r1 = Cells(Rows.Count, 16).End(xlUp).Row
        For i = r1 To r Step -1
            If Cells(i, "p") = 0 And Not Cells(i, "p").MergeCells Then
                Rows(i).Delete
            End If
        Next
        r2 = Cells(Rows.Count, 16).End(xlUp).Row
        If Cells(r2, 16).MergeCells Then
            r2 = Cells(r2, 16).MergeArea.Row + Cells(r2, 16).MergeArea.Rows.Count - 1
        Else
            r2 = Cells(r2, 16).Row
        End If
        With Range("B" & r & ":B" & r2 & ",C" & r & ":C" & r2 & ",D" & r & ":D" & r2 & ",E" & r & ":E" & r2)
            .Merge
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlCenter
            .Borders.LineStyle = xlContinuous
            .Borders(xlEdgeLeft).Weight = xlThin
            .Borders(xlEdgeTop).Weight = xlThin
            .Borders(xlEdgeBottom).Weight = xlThin
            .Borders(xlEdgeRight).Weight = xlThin
        End With
        Mfile = Dir
    Loop Until Mfile = ""
    Range("b8").Select
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

shiruiqiang

按照你的格式来
必须保证每张表内有"房号", "二、明细附后。"这两个

一壶鱼

多谢两位大佬，我测试一下

一壶鱼

br(i) = .Sheets(1).UsedRange.Find(temp(i)).Row
这个是什么意思啊！

一壶鱼

发哥76 发表于 2024-6-1 21:28
给你硬凑了一个，试一下：
Sub test()
    Application.ScreenUpdating = False

pasteRange.PasteSpecial Paste:=xlPasteAll
测试有问题，这是什么意思

一壶鱼

shiruiqiang 发表于 2024-6-1 21:56
按照你的格式来
必须保证每张表内有"房号", "二、明细附后。"这两个

br(i) = .Sheets(1).UsedRange.Find(temp(i)).Row

发哥76

一壶鱼 发表于 2024-6-1 22:20
pasteRange.PasteSpecial Paste:=xlPasteAll
测试有问题，这是什么意思

复制粘贴啊，在我这里好用哦，