求助：多个EXCEL独立的文件，合并成一个EXCEL表格，并剔除其中一列中的1

加林果

多个表汇总成一个表，且D列不包含1，请大神们支招！万分感谢！

加林果

正在用2013版本，试过搜索帖子一些教程，用的代码是把首列都去掉了的，但我的数据中没有首列，去掉就不对了。

加林果

求大神们支招~~~~

x-xx-xx

你这个没有标题,代码改改就好了

x-xx-xx

Sub 汇总()
    Application.ScreenUpdating = False '关闭屏幕刷新
    Dim wb As Excel.Workbook
    Dim sh As Excel.Worksheet
    Set sh = ThisWorkbook.Worksheets(1)
    f = Dir(ThisWorkbook.Path & "\*.xls*") '生成查找EXCEL的目录,可以适应不同版本
    Do While f <> "" '在目录中循环
        If f <> ThisWorkbook.Name Then  '如果不是打开的工作簿
            Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f) '依次打开目录工作薄
            arr = wb.Worksheets(1).[a1].CurrentRegion
            sh.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arr), UBound(arr, 2)) = arr
            wb.Close False '关闭打开的工作薄
        End If
        f = Dir
    Loop '结束循环
    MsgBox "共汇总了" & n & "个文件"
    Application.ScreenUpdating = True '打开屏幕刷新
End Sub

x-xx-xx

1的你自己筛选下删掉好了

加林果

x-xx-xx 发表于 2018-9-26 14:29
1的你自己筛选下删掉好了

太好了，谢谢您！！我研究了四个小时了都，终于解决了，么么哒~~~

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, filename(), i, j, k, m
  If Not getfilename(filename, ThisWorkbook.Path, "xlsx") Then MsgBox "!": Exit Sub
  ReDim brr(1 To Rows.Count, 1 To 5)
  For i = 1 To UBound(filename)
    If filename(i) <> ThisWorkbook.FullName And Left(filename(i), 1) <> "~" Then
      With GetObject(filename(i))
        arr = .ActiveSheet.[a1].CurrentRegion
        For j = 1 To UBound(arr, 1)
          If arr(j, 4) <> 1 Then
            m = m + 1
            For k = 1 To UBound(arr, 2): brr(m, k) = arr(j, k): Next
          End If
        Next
        .Close
      End With
    End If
  Next
  With [a1]
    .Resize(Rows.Count, UBound(brr, 2)).ClearContents
    If m > 0 Then .Resize(m, UBound(brr, 2)) = brr
  End With
End Sub

Function getfilename(filename, pth, mark) As Boolean
  Dim f, n
  If Right(pth, 1) <> "\" Then pth = pth & "\"
  f = Dir(pth & "*.*")
  Do While Len(f) > 0
    If LCase(Right(f, Len(mark))) = LCase(mark) Then
      n = n + 1: ReDim Preserve filename(1 To n)
      filename(n) = pth & f
    End If
    f = Dir
  Loop
  If n > 0 Then getfilename = True
End Function

x-xx-xx

Sub 汇总()
    Application.ScreenUpdating = False '关闭屏幕刷新
    Dim wb As Excel.Workbook
    Dim sh As Excel.Worksheet
    Set sh = ThisWorkbook.Worksheets(1)
    f = Dir(ThisWorkbook.Path & "\*.xls*") '生成查找EXCEL的目录,可以适应不同版本
    Do While f <> "" '在目录中循环
        If f <> ThisWorkbook.Name Then  '如果不是打开的工作簿
            Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f) '依次打开目录工作薄
            n = n + 1
            arr = wb.Worksheets(1).[a1].CurrentRegion
            sh.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arr), UBound(arr, 2)) = arr
            wb.Close False '关闭打开的工作薄
        End If
        f = Dir
    Loop '结束循环
    MsgBox "共汇总了" & n & "个文件"
    Application.ScreenUpdating = True '打开屏幕刷新
End Sub

加林果

万分感谢你们~~