分类合并文件夹工作簿，并保留工作簿名称

623277606

跪求大神老师指点，想把文件夹中的7个工作簿，按照集团＋股份分成2＋5的形式（已在汇总表中做了示例），保留文件薄名称，剔除表头和底部签字，请赐教

zxsea_7426

这截图中黄色是什么原因不提取，一个表不提取，其他表都提取，判断标准不一致。

chzsh

Sub shenpi()
Dim arr()
Dim wb As Workbook
Dim wbi, j, wbj, k, wbzh As Integer
Dim bgzb As Sheet1

Application.DisplayAlerts = False '关闭警告
Application.ScreenUpdating = False '关闭屏幕刷新
Application.Calculation = xlManual '关闭自动计算

Sheets(1).Range("a2:i10000").Clear '清空数据
Sheets(2).Range("a2:i10000").Clear '清空数据
arr = Application.GetOpenFilename("Excel文件,*.xls*", 2, , , True)
If arr(1) <> "False" Then
    For i = LBound(arr) To UBound(arr)
        Set wb = Workbooks.Open(arr(i))
        nm = Split(wb.Name, ".")(0)
            If nm = "全市24-汇总实收付日结单-7版集团" Or nm = "全市24-汇总实收付日结单-OBPS老业务" Then
                 wbzh = wb.Sheets(1).Range("e65536").End(xlUp).Row
                  k = ThisWorkbook.Sheets(1).Range("a65536").End(xlUp).Row
                 If wbzh = 4 Then ThisWorkbook.Sheets(1).Cells(k + 1, 1) = nm
                 If wbzh > 4 Then
                    wb.Sheets(1).Range("a5:e" & wbzh).Copy
                    ThisWorkbook.Sheets(1).Cells(k + 1, 2).PasteSpecial Paste:=xlPasteValues
                    ThisWorkbook.Sheets(1).Cells(k + 1, 1).Resize(wbzh - 4, 1) = nm
                 End If
                 
            Else
            
                  wbzh = wb.Sheets(1).Range("e65536").End(xlUp).Row
                  k = ThisWorkbook.Sheets(2).Range("a65536").End(xlUp).Row
                 If wbzh = 4 Then ThisWorkbook.Sheets(2).Cells(k + 1, 1) = nm
                 If wbzh > 4 Then
                    wb.Sheets(1).Range("a5:e" & wbzh).Copy
                    ThisWorkbook.Sheets(2).Cells(k + 1, 2).PasteSpecial Paste:=xlPasteValues
                     ThisWorkbook.Sheets(2).Cells(k + 1, 1).Resize(wbzh - 4, 1) = nm
                 End If
                 
                 
            End If
        wb.Close
    Next
End If
    ms = ThisWorkbook.Sheets(1).Range("a65536").End(xlUp).Row '确定当前表最后一行
     ThisWorkbook.Sheets(1).Range("a1:f" & ms).Borders.LineStyle = 1 '从a1开始到f最后一行加上框线
     n = ThisWorkbook.Sheets(2).Range("a65536").End(xlUp).Row '确定当前表最后一行
     ThisWorkbook.Sheets(2).Range("a1:f" & n).Borders.LineStyle = 1 '从a1开始到f最后一行加上框线
Application.Calculation = xlAutomatic '开启自动计算
Application.DisplayAlerts = True '开启警告
Application.ScreenUpdating = True '开启屏幕刷新

End Sub

chzsh

不知对不对，先试试吧