刚才发了个网盘链接，好像帖子给吞了。
需求说明：
将N个此文件中的内容复制到一薄一表中，第1、2、3行为标题行，内容一样，只复制一次，其他的不要标题行与最后一行内容。
最右侧数据到BU列
第1、2行为合并单元格，最后一行也是合并单元格，系统导出的就是这样。

链接：[无效] https://pan.baidu.com/s/1fLVHzHJUd-HoluhrY8cNOA?pwd=8888
提取码：8888

如果没有几个文件先手工打开再另存为xlsx文件，然后估计2个for走一圈就解决了。
文件如果很多可以用workbooks.open(filename) 方法打开文件，用getobjct(filename) 就你这问题肯定不行的。
如果open打开也有问题，那打开后用do加个1s的延时去findwindow弹出窗口句柄，如果失败说明正常运行，否则枚举此句柄下的command句柄，包含有“Y”就sendmessage 一个click参数过去就可以了，后面的窗口操作方法相同（自己查一下相关API函数的使用方法）。
导出数据是是否有选项，比如文件类型可为csv或者xlsx的，xls太古老了。

'瞎子又在审核

方方格子

这要是有难度的话，能不能做到将一个文件夹内的所有XLS文件另存为XLSX格式，并且删除前3行与最后一行内容？

hi，这是我用百度网盘分享的内容~复制这段内容打开「百度网盘」APP即可获取
链接:网页链接
提取码:rqbv

链接: 网页链接 提取码: rqbv 复制这段内容后打开百度网盘手机App，操作更方便哦

'在当前目录新建一个xlsm文件并复制代码到模块，关闭当前目录中的所有xls文件（否则open时会有问题，未做error处理）
'随机测试了几个xls文件正常，你这文件我就搞不清楚了。源数据在当前工作簿的当前表格中
Option Explicit
Sub abc()
　Dim a, f, n, m, p, w, pth
　Call doevent(False)
　pth = ThisWorkbook.Path & "\"
　f = Dir(pth & "*.*")
　Do While Len(f) > 0
　　If LCase(Right(f, 4)) = ".xls" And Left(f, 1) <> "~" Then 'xls文件且非临时文件
　　　　Set w = Workbooks.Open(pth & f)
　　　　With w
　　　　With .ActiveSheet
　　　　　a = .[a1].CurrentRegion.Value
　　　　　If IsArray(a) Then '当前表格有数据区
　　　　　　m = m + 1
　　　　　　If m = 1 Then
　　　　　　　.[a1].Resize(UBound(a) - 1, UBound(a, 2)).Copy _
　　　　　　　　ThisWorkbook.ActiveSheet.[a1]
　　　　　　Else
　　　　　　　p = ThisWorkbook.ActiveSheet.Cells(Rows.Count, "a").End(xlUp).Row + 1
　　　　　　　.[a1].Offset(3).Resize(UBound(a) - 4, UBound(a, 2)).Copy _
　　　　　　　　ThisWorkbook.ActiveSheet.Cells(p, "a")
　　　　　　End If
　　　　　Else
　　　　　　Debug.Print pth & f
　　　　　End If
　　　　End With
　　　　.Close False
　　　　End With
　　End If
　　f = Dir
　Loop
　Call doevent(True)
End Sub
Function doevent(flag As Boolean)
　With Application
　　.DisplayAlerts = flag
　　.ScreenUpdating = flag
　End With
End Function

'出现第一种情况是因为源数据有问题，如果最后一行没有合并行那么数据将会丢失，已修改
'排序需要规则，文件名按py升序处理，你也可以改成按asc升序来排序，或者抓图上规则再修改
Option Explicit
Sub abc()
　Dim a, i, f, n, m, p, w, pth, filename(1 To 10 ^ 4, 1 To 3), cnt
　pth = ThisWorkbook.Path
　If Not getfilename(filename, cnt, pth, ".xls") Then MsgBox "!": Exit Sub
　Call bsort(filename, 1, cnt, 1, 3, 3) '默认按文件名py升序，可改成asc或提供规则自定义
　Call doevent(False)
　For i = 1 To cnt
　　Set w = Workbooks.Open(filename(i, 1))
　　With w
　　　With .ActiveSheet
　　　　a = .[a1].CurrentRegion.Value
　　　　If IsArray(a) Then '当前表格有数据区
　　　　　m = m + 1
　　　　　If m = 1 Then '包括标题
　　　　　　.[a1].Resize(UBound(a), UBound(a, 2)).Copy _
　　　　　　　ThisWorkbook.ActiveSheet.[a1]
　　　　　Else '去除前3行标题
　　　　　　p = ThisWorkbook.ActiveSheet.Cells(Rows.Count, "a").End(xlUp).Row + 1
　　　　　　.[a1].Offset(3).Resize(UBound(a) - 3, UBound(a, 2)).Copy _
　　　　　　　ThisWorkbook.ActiveSheet.Cells(p, "a")
　　　　　End If
　　　　Else
　　　　　Debug.Print filename(i, 1) '如果有输出说明这个问题数据有问题，打开确认一下
　　　　End If
　　　End With
　　　.Close False
　　End With
　Next
　For i = Cells(Rows.Count, "a").End(xlUp).Row To 4 Step -1 '删除合计行
　　If InStr(Cells(i, "a"), "合计行") > 0 Then Rows(i).Delete
　Next
　Call doevent(True)
End Sub
Function getfilename(filename, cnt, pth, mark) As Boolean
　Dim f
　If right(pth, 1) <> "\" Then pth = pth & "\"
　f = Dir(pth & "*.*")
　Do While Len(f) > 0
　　If LCase(right(f, Len(mark))) = LCase(mark) Then
　　　If left(f, 1) <> "~" Then
　　　　cnt = cnt + 1
　　　　filename(cnt, 1) = pth & f
　　　　filename(cnt, 2) = LCase(f)
　　　　filename(cnt, 3) = LCase(left(f, Len(f) - Len(mark)))
　　　End If
　　End If
　　f = Dir
　Loop
　If cnt > 0 Then getfilename = True
End Function
Function bsort(a, first, last, left, right, key)
　Dim i, j, k, t
　For i = first To last - 1
　　For j = first To last + first - 1 - i
　　　If StrComp(a(j, key), a(j + 1, key), vbTextCompare) = 1 Then 'by py
　　　'If a(j, key) > a(j + 1, key) Then 'by asc
　　　　For k = left To right
　　　　　t = a(j, k): a(j, k) = a(j + 1, k): a(j + 1, k) = t
　　　　Next
　　　End If
　Next j, i
End Function
Function doevent(flag As Boolean)
　With Application
　　.DisplayAlerts = flag
　　.ScreenUpdating = flag
　End With
End Function

才注意到每个文件的最下方有两行合并单元格，会不会是因为这个的原因，才导致提取的数据中间有一个合计行？

Export_10010002[1_5000].xls
Export_10010002[10001_15000].xls
Export_10010002[15001_20000].xls
Export_10010002[20001_25000].xls
Export_10010002[25001_30000].xls
Export_10010002[30001_35000].xls
Export_10010002[35001_40000].xls
Export_10010002[40001_45000].xls
Export_10010002[45001_48126].xls
Export_10010002[5001_10000].xls

'按文件名命名规则做了升序,随机测试了一下汇总数据都没有问题。
'源文件"合计"标志必须在A列，缺少源文件就猜到这里了。
Option Explicit
Sub abc()
　Dim a, i, f, n, m, p, w, pth, filename(1 To 10 ^ 4, 1 To 3), cnt
　pth = ThisWorkbook.Path
　If Not getfilename(filename, cnt, pth, ".xls") Then MsgBox "!": Exit Sub
　Call doevent(False)
　Cells.ClearContents
　For i = 1 To cnt
　　Set w = Workbooks.Open(filename(i, 1))
　　With w
　　　With .ActiveSheet
　　　　a = .[a1].CurrentRegion.Value
　　　　If IsArray(a) Then
　　　　　m = m + 1
　　　　　If m = 1 Then
　　　　　　.[a1].Resize(UBound(a), UBound(a, 2)).Copy _
　　　　　　　ThisWorkbook.ActiveSheet.[a1]
　　　　　Else
　　　　　　p = ThisWorkbook.ActiveSheet.Cells(Rows.Count, "a").End(xlUp).Row + 1
　　　　　　.[a1].Offset(3).Resize(UBound(a) - 3, UBound(a, 2)).Copy _
　　　　　　　ThisWorkbook.ActiveSheet.Cells(p, "a")
　　　　　End If
　　　　Else
　　　　　Debug.Print filename(i, 1)
　　　　End If
　　　End With
　　　.Close False
　　End With
　Next
　For i = Cells(Rows.Count, "a").End(xlUp).Row To 4 Step -1
　　If InStr(Cells(i, "a").Value, "合计") > 0 Then Rows(i).Delete
　Next
　Call doevent(True)
End Sub
Function getfilename(filename, cnt, pth, mark) As Boolean
　Dim f, i, t, p
　If right(pth, 1) <> "\" Then pth = pth & "\"
　f = Dir(pth & "*.*")
　Do While Len(f) > 0
　　If LCase(right(f, Len(mark))) = LCase(mark) Then
　　　If left(f, 1) <> "~" Then
　　　　cnt = cnt + 1
　　　　filename(cnt, 1) = pth & f
　　　　If InStr(f, "[") Then
　　　　　t = Split(f, "[")
　　　　　filename(cnt, 2) = t(0)
　　　　　If InStr(t(1), "_") Then
　　　　　　t = Split(t(1), "_")
　　　　　　If IsNumeric(t(0)) Then
　　　　　　　filename(cnt, 3) = Val(t(0))
　　　　　　Else
　　　　　　　MsgBox pth & f: End
　　　　　　End If
　　　　　Else
　　　　　　MsgBox pth & f: End
　　　　　End If
　　　　Else
　　　　　MsgBox pth & f: End
　　　　End If
　　　End If
　　End If
　　f = Dir
　Loop
　If cnt > 0 Then
　　Call bsort(filename, 1, cnt, 1, 3, 2)
　　For i = 1 To cnt
　　　If filename(i, 2) <> filename(i + 1, 2) Then
　　　　Call bsort(filename, p + 1, i, 1, 3, 3)
　　　　p = i
　　　End If
　　Next
　　getfilename = True
　End If
End Function
Function bsort(a, first, last, left, right, key)
　Dim i, j, k, t
　For i = first To last - 1
　　For j = first To last + first - 1 - i
　　　If a(j, key) > a(j + 1, key) Then
　　　　For k = left To right
　　　　　t = a(j, k): a(j, k) = a(j + 1, k): a(j + 1, k) = t
　　　　Next
　　　End If
　Next j, i
End Function
Function doevent(flag As Boolean)
　With Application
　　.DisplayAlerts = flag
　　.ScreenUpdating = flag
　End With
End Function