求帮忙！多个电子表格人员信息批量提取到一个汇总文件

{MR.WANG}

求帮忙！多个电子表格人员信息批量提取到一个汇总文件

liulang0808

http://club.excelhome.net/thread-1258425-1-1.html
遍历文件资料，

fxl447098457

看看别人的解法：https://pqfans.com/2149.html

一把小刀闯天下

'有问题自己修改一下pos数组即可，，，

Option Explicit

Sub 汇总()
  Dim filename(), pos, i, j, m, t
  If Not getfilename(filename, ThisWorkbook.Path, ".xlsx") Then MsgBox "!": Exit Sub
  pos = Split("C2 H2 C3 E3 G3 C4 E4 G4 C5 E5 G5 C6 G6 C7 G7 C8 H8 C9 F9 H9 C10 F10 H10 C12 C13 E13 G12 H13 C15 E15 G15 I15")
  ReDim brr(1 To UBound(filename), 1 To UBound(pos) + 4)
  For i = 1 To UBound(filename)
    m = m + 1
    t = Split(filename(i), "\")
    brr(m, 1) = t(UBound(t)): brr(m, 2) = i
    t = Replace(filename(i), brr(m, 1), vbNullString)
    brr(m, UBound(brr, 2)) = Left(t, Len(t) - 1)
    With GetObject(filename(i))
      For j = 0 To UBound(pos): brr(m, j + 3) = .Sheets([b1].Value).Range(pos(j)): Next
      .Close False
    End With
  Next
  With [a5]
    .Resize(Rows.Count - 4, UBound(brr, 2)).ClearContents
    .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) And Left(f, 1) <> "~" 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

opiona

http://club.excelhome.net/thread-1409141-1-1.html

{MR.WANG}

liulang0808 发表于 2018-12-25 13:46
http://club.excelhome.net/thread-1258425-1-1.html
遍历文件资料，

谢谢，学习一下。

{MR.WANG}

一把小刀闯天下 发表于 2018-12-25 16:00
'有问题自己修改一下pos数组即可，，，

Option Explicit

感谢大神，完美运行成功，谢谢！