如何提取数据

bbcc100

求助：

同一文件夹里，工作簿数量不定
每个工作簿的Sheet1的A:B列，都会有数据，但数据不等
需要把每个工作簿 Sheet1  的A:B列的数据，依次放到《希望得到的结果》
《希望得到的结果》，目前是手工做出来的，希望能够用宏得到这种结果
工作簿为*.xlsm格式

cjc209

Sub 动态字段多薄多表合并为一表()
    Dim d, ar, br, sh As Worksheet, cr()
    Set d = CreateObject("Scripting.Dictionary")
    ThisWorkbook.Sheets.Add
     ActiveSheet.Name = "合并结果"
    bth = Val(Application.InputBox("请输入  需要的字段名所在的行号：", "默认值", "1"))
    Application.ScreenUpdating = False
   
p = ThisWorkbook.Path & "\"
f = Dir(p & "*.xls*")
Do While f <> ""
   If f <> ThisWorkbook.Name Then
   With Workbooks.Open(p & f)
     For Each sh In Sheets
       qsl = sh.UsedRange.Column
       zdl = sh.UsedRange.Columns.Count + sh.UsedRange.Column - 1
       dzdh = sh.UsedRange.Rows.Count + sh.UsedRange.Row - 1
       qsh = bth
       zdh = sh.Cells(65536, qsl).End(xlUp).Row
       dhs = dzdh - bth
       zhs = zhs + dhs
        If sh.Name <> "合并结果" Then
         If zdh > 1 Then
            ar = sh.Cells(qsh, qsl).Resize(zdh - qsh + 1, zdl)
         
            For i = 1 To UBound(ar, 2)
            
                d(ar(1, i)) = 0
            
            Next
         End If
        End If
     Next
    .Close 0
    End With
  End If
f = Dir
Loop
    ReDim br(1 To zhs + 1, 1 To d.Count): m = 1
    For i = 1 To d.Count
        d(d.keys()(i - 1)) = i
        br(1, i) = d.keys()(i - 1)
    Next
   
p = ThisWorkbook.Path & "\"
f = Dir(p & "*.xls*")
Do While f <> ""
   If f <> ThisWorkbook.Name Then
   With Workbooks.Open(p & f)
   
    For Each sh In Sheets
       qsl = sh.UsedRange.Column
       zdl = sh.UsedRange.Columns.Count + sh.UsedRange.Column - 1
       qsh = bth
       zdh = sh.Cells(65536, qsl).End(xlUp).Row
        If sh.Name <> "合并结果" Then
         If zdh > 1 Then
            ar = sh.Cells(qsh, qsl).Resize(zdh - qsh + 1, zdl)
            
            For i = 2 To UBound(ar)
                m = m + 1
                For j = 1 To UBound(ar, 2)
                  
                    br(m, d(ar(1, j))) = ar(i, j)
                    ReDim Preserve cr(1 To m)
                    If m = 2 Then
                    cr(1) = "数据来源"
                    End If
                   cr(m) = f & "_" & sh.Name
                Next j
            Next i
         End If
        End If
    Next
   
       .Close 0
    End With
  End If
f = Dir
Loop
   
    With ActiveSheet
        .[a1].Resize(m, UBound(br, 2)) = br
        .[a1].Offset(0, UBound(br, 2)).Resize(m, 1) = Application.Transpose(cr)
    End With
    LastRow = ActiveSheet.UsedRange.Rows.Count
    LastRow = LastRow + ActiveSheet.UsedRange.Row - 1
    For r = LastRow To 1 Step -1
      If WorksheetFunction.CountA(Rows(r)) = 0 Then Rows(r).Delete
    Next r
   LastColumn = ActiveSheet.UsedRange.Columns.Count
   LastColumn = LastColumn + ActiveSheet.UsedRange.Column
  For c = LastColumn To 1 Step -1
    If WorksheetFunction.CountA(Columns(c)) = 0 Then Columns(c).Delete
  Next c

    Application.ScreenUpdating = True
    MsgBox "合并完成！"
End Sub

cjc209

简单         解决

cjc209

你的答案   

liulang0808

http://club.excelhome.net/thread-1258425-1-1.html
楼主参考下这个吧

bbcc100

谢谢楼上  热心的大师，问题尚未解决，有没老师能帮忙解决吗？

bbcc100

测试了，有差别，不知有没老师，能帮忙解决？

一把小刀闯天下

'表格并不规范，，，

Option Explicit

Sub test()
  Dim i, j, filename(), m, n, dic, f, arr
  If Not getfilename(filename, ThisWorkbook.Path, ".xlsm") Then MsgBox "!": Exit Sub
  Set dic = CreateObject("scripting.dictionary")
  ReDim brr(1 To 10 ^ 4, 1 To 30): n = 2
  For i = 1 To UBound(filename)
    With GetObject(filename(i))
      arr = .Sheets("sheet1").UsedRange
      .Close
    End With
    f = Split(filename(i), "\")
    f = Left(f(UBound(f)), InStrRev(f(UBound(f)), ".") - 1)
    If Not dic.exists(arr(1, 2)) Then n = n + 1: dic(arr(1, 2)) = n
    For j = 2 To UBound(arr, 1)
      m = m + 1: brr(m, 2) = arr(j, 1): brr(m, dic(arr(1, 2))) = arr(j, 2)
      If j = 2 Then brr(m, 1) = f
  Next j, i
  With Sheets("希望得到的结果").[a1]
    .Resize(Rows.Count, n + 5).ClearContents
    .Offset(, 2).Resize(, dic.Count) = dic.keys
    .Offset(1).Resize(m, n) = 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
      If Left(f, 1) <> "~" And InStr(f, "如何提取数据") = 0 Then
        n = n + 1: ReDim Preserve filename(1 To n)
        filename(n) = pth & f
      End If
    End If
    f = Dir
  Loop
  If n > 0 Then getfilename = True
End Function

bbcc100

2楼大师，您帮我解决的，很完美，也是怪，昨晚我应该是看错了，今早再试，很完美。非常感谢您！！！！

bbcc100

一把小刀闯天下 发表于 2018-12-15 09:59
'表格并不规范，，，

Option Explicit

http://club.excelhome.net/thread-1451592-1-1.html尊敬的大师，昨晚上网看到您的帮助，非常感谢您的帮助，但我不懂得使用，同时，如果它要取每张表的第三列，第四列的数据呢（求助文件是假设要取每张表的第一列，第二列的）