超难,灵活指定文件夹中表的行列数然后提取每个月的数据

excel学习123

天道酬勤y 发表于 2017-3-6 14:49
洗选厂里面的表是取的和工作簿动力厂里面的表列数一致的吗?我看动力厂取的什么好像洗选厂就取的什么,如果 ...

老师能帮忙看一下这个吗？难题，帮忙修改一下， 以A列为所列数据为基础，汇总余额表的H-K列数据相应数据
http://club.excelhome.net/thread-1332252-1-1.html
(出处: ExcelHome技术论坛)

乐乐2006201505

天道酬勤y 发表于 2017-3-6 14:49
洗选厂里面的表是取的和工作簿动力厂里面的表列数一致的吗?我看动力厂取的什么好像洗选厂就取的什么,如果 ...

你自己试试，理论上来说，不一样。因为你的数据不是真实数据，对起来也比较麻烦，你用实际数据试试，看有问题吗？
我刚试了，没问题，你下载附件试试。

乐乐2006201505

天道酬勤y 发表于 2017-3-6 14:49
洗选厂里面的表是取的和工作簿动力厂里面的表列数一致的吗?我看动力厂取的什么好像洗选厂就取的什么,如果 ...

你说的问题已修正。

Sub fz父子转换法()
  'On Error Resume Next
  Dim 父亲(1 To 1000) As String
  Dim f, i, i1, i2, i3, k, k1, irow, irow1, irow2, irow3, c As Range, f2, f3, x, sh As Worksheet
  Dim arr1(1 To 1000, 1 To 1) As String, q As Integer
  Dim arr(1 To 1000, 1 To 70)
  Dim t#, d As Object
  Dim maxh&
    Set d = CreateObject("scripting.dictionary")
    For Each sh In Sheets
        Set d(sh.Name) = sh
    Next
  父亲(1) = ThisWorkbook.Path & "\"
  i = 1: k = 1
  Do While i < UBound(父亲)
    If 父亲(i) = "" Then Exit Do
    f = Dir(父亲(i), vbDirectory)
    Do
      If InStr(f, ".") = 0 And f <> "" Then
        k = k + 1
        父亲(k) = 父亲(i) & f & "\"
      End If
      f = Dir
    Loop Until f = ""
    i = i + 1
  Loop
  '*******下面是提取各个文件夹的文件***
  For x = 1 To UBound(父亲)
      If 父亲(x) = "" Then Exit For
       f3 = Dir(父亲(x) & "*.xls?")
     Do While f3 <> ""
        If f3 <> ThisWorkbook.Name Then
          q = q + 1
          arr1(q, 1) = 父亲(x) & f3
          Workbooks.Open arr1(q, 1)
            With ActiveWorkbook
                For i3 = 1 To .Sheets.Count
                     With Sheets(i3)   '在这里，改变i3为具体数值，可指定某个具体工作表，如只汇总每个工作簿第一个，数值为1即可。
                        i5 = ThisWorkbook.Sheets(Mid(VBA.Replace(f3, ".xls", ""), InStr(f3, "月") + 1, 3) & "产品台账").Range("q5").End(2).Column
                        For i7 = ThisWorkbook.Sheets(Mid(VBA.Replace(f3, ".xls", ""), InStr(f3, "月") + 1, 3) & "产品台账").Range("q5").Column To i5 Step 2
                        i2 = ThisWorkbook.Sheets(Mid(VBA.Replace(f3, ".xls", ""), InStr(f3, "月") + 1, 3) & "产品台账").Cells(5, i7).Value
                            If d.Exists(ThisWorkbook.Sheets(Mid(VBA.Replace(f3, ".xls", ""), InStr(f3, "月") + 1, 3) & "产品台账").Cells(4, i7).Value & "产品台账") Then
                                If i2 <> "" And .Name = i2 Then
                                irow = ThisWorkbook.Sheets(Mid(VBA.Replace(f3, ".xls", ""), InStr(f3, "月") + 1, 3) & "产品台账").Cells(7, i7).Value
                                k1 = ThisWorkbook.Sheets(Mid(VBA.Replace(f3, ".xls", ""), InStr(f3, "月") + 1, 3) & "产品台账").Cells(6, i7).Value
                                i1 = ThisWorkbook.Sheets(Mid(VBA.Replace(f3, ".xls", ""), InStr(f3, "月") + 1, 3) & "产品台账").Range("a65536").End(3).Row
                                i4 = 3
                                i8 = ThisWorkbook.Sheets(Mid(VBA.Replace(f3, ".xls", ""), InStr(f3, "月") + 1, 3) & "产品台账").Cells(65536, i7).End(3).Row
                                    For Each c In ThisWorkbook.Sheets(Mid(VBA.Replace(f3, ".xls", ""), InStr(f3, "月") + 1, 3) & "产品台账").Range(ThisWorkbook.Sheets(Mid(VBA.Replace(f3, ".xls", ""), InStr(f3, "月") + 1, 3) & "产品台账").Cells(8, i7), ThisWorkbook.Sheets(Mid(VBA.Replace(f3, ".xls", ""), InStr(f3, "月") + 1, 3) & "产品台账").Cells(i8, i7))
                                    i4 = i4 + 1
                                        .Range(c.Value & k1 & ":" & c.Value & irow).Copy ThisWorkbook.Sheets(Mid(VBA.Replace(f3, ".xls", ""), InStr(f3, "月") + 1, 3) & "产品台账").Cells(i1 + 1, i4)
                                    Next
                                ThisWorkbook.Sheets(Mid(VBA.Replace(f3, ".xls", ""), InStr(f3, "月") + 1, 3) & "产品台账").Range("a" & i1 + 1 & ":a" & i1 + irow - 5) = Left(VBA.Replace(f3, ".xls", ""), InStr(f3, "月"))
                                ThisWorkbook.Sheets(Mid(VBA.Replace(f3, ".xls", ""), InStr(f3, "月") + 1, 3) & "产品台账").Range("b" & i1 + 1 & ":b" & i1 + irow - 5) = Mid(VBA.Replace(f3, ".xls", ""), InStr(f3, "月") + 1, 3)
                                ThisWorkbook.Sheets(Mid(VBA.Replace(f3, ".xls", ""), InStr(f3, "月") + 1, 3) & "产品台账").Range("c" & i1 + 1 & ":c" & i1 + irow - 5) = Sheets(i3).Name
                                End If
                            End If
                        Next
                     End With
                Next
                .Close False
            End With
        End If
        f3 = Dir
     Loop
  Next x
End Sub