求大神赐教或编写代码

mhhu

有多个Excel文件（大概格式如附件，有差异），每个文件里有（部分文件里或者没有相应数据）需要提取的项目数据，各文件所需项目数据位置不一，求：
将各个文件里相应项目的数据（以文本形式储存）提取出来并汇总到一个表中，没有相应数据的文件自动跳过或标示“无 / -”等标识。

以上要求不知道能否实现。本人对程序代码一窍不通，请大师帮忙提点，谢谢！

从多个Excel文件中不同位置提取数据？？.rar (33.29 KB, 下载次数: 3)

2018-8-7 13:28 上传

点击文件名下载附件

mhhu

已重新上传附件，请指教！

一把小刀闯天下

mhhu 发表于 2018-8-7 13:40
已重新上传附件，请指教！

'名称要跟表格中的完全一样，就像"血糖"表格中叫"葡萄糖(GLU)",,,

Option Explicit

Sub test()
  Dim arr, i, j, dic, filename(), t, brr
  Set dic = CreateObject("scripting.dictionary")
  arr = [a1].CurrentRegion
  For i = 5 To UBound(arr, 2): dic(arr(1, i)) = i: Next
  ReDim arr(1 To Rows.Count, 1 To UBound(arr, 2))
  If Not getfilename(ThisWorkbook.Path, filename, ".xls") Then MsgBox "!": Exit Sub
  For i = 1 To UBound(filename)
    t = Split(filename(i), "\"): arr(i, 1) = Split(t(UBound(t)), ".")(0)
    With GetObject(filename(i))
      With .ActiveSheet
        brr = .Range("a2:e" & .Cells(.Rows.Count, "a").End(xlUp).Row)
        arr(i, 2) = Split(Split(brr(1, 1), "姓名：")(1))(0)
        arr(i, 3) = Split(Split(brr(1, 1), "性别：")(1))(0)
        arr(i, 4) = Split(brr(1, 1), "年龄：")(1)
        For j = 2 To UBound(brr, 1)
          If dic.exists(brr(j, 1)) Then arr(i, dic(brr(j, 1))) = brr(j, 2)
        Next
      End With
      .Close
    End With
  Next
  With [a2]
    .Resize(Rows.Count - 1, UBound(arr, 2)).ClearContents
    .Resize(i - 1, UBound(arr, 2)) = arr
  End With
End Sub

Function getfilename(pth, filename, mark) As Boolean
  Dim f, n
  pth = pth & IIf(Right(pth, 1) = "\", "", "\")
  f = Dir(pth & "*.*")
  Do Until 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