求助E坛老师纠错：多簿遍历条件查询提取到新簿表的字典数组法

2007小金猪 · 发表于 2020-2-6 13:20

本帖最后由 2007小金猪于 2020-2-6 13:34 编辑

求助论坛老师：
遍历同一文件夹下，用字典数组遍历查询（满足条件）提取到新工作簿的某一表中。不汇总求和。
记录重复的，满足条件的也提取。
最终目标：数据已存入“样本”数据的表里
主要错误：（1)不能把满足条件的多工作簿中的提取保存到依次追加到新表，只保留了最后一次的。
                  （2）表头标题未取出。

  调试了许久，功力不足，无法纠正错误。
数据在附件中。

感谢论坛热心老师
Sub TQV()
Dim mypath$, myname$, arr, brr(), j&, m&
Dim i&
Dim a, t, k
t = Timer
Application.ScreenUpdating = False
mypath = ThisWorkbook.Path & "\"
myname = Dir(mypath & "*.xls")
Do While myname <> ""
  If myname <> ThisWorkbook.Name Then

   With GetObject(mypath & myname)

   arr = .Sheets(1).[a2].CurrentRegion
         .Close False


End With

  End If

   a = Array(10, 15, 11, 12, 13, 14, 6, 7)

   ReDim brr(2 To UBound(arr), 0 To 7)

For i = 2 To UBound(arr)

   If Len(arr(i, 6)) > 0 And arr(i, 15) = "a11" Then

      For j = 0 To 7

      brr(i, j) = arr(i, a(j))

      Next

      End If

   Next

[a1].CurrentRegion.Offset(2).ClearContents

[a2].Resize(i - 2, 8) = brr

      myname = Dir

      i = i + UBound(arr)

Loop

   k = Sheet1.Cells(300000, 1).End(3).Row

Sheet1.Range("A2:H" & k).Sort Key1:=Sheet1.Range("A3"), Order1:=xlAscending, key2:=Sheet1.Range("G3"), Order2:=xlAscending, Header:=xlYes

Application.ScreenUpdating = True

MsgBox "???????!???" & Format(Timer - t, "0.000") & "??"

End Sub

abc123281 · 发表于 2020-2-6 14:29

本帖最后由 abc123281 于 2020-2-6 17:01 编辑

文件123.rar (1.69 MB, 下载次数: 7)

2007小金猪 · 发表于 2020-2-6 15:48

本帖最后由 2007小金猪于 2020-2-6 15:55 编辑

abc123281 发表于 2020-2-6 14:29

bc123281老师：非常感谢您的热心关注和帮助、指点。
有一个缺陷：（1）符合条件的提取，每增加一个工作簿，少了一行记录；（2）

表头标题未取出

。

liulang0808 · 发表于 2020-2-6 16:52

本帖最后由 liulang0808 于 2020-2-6 17:11 编辑

附件内容供参考。。。。。。

abc123281 · 发表于 2020-2-6 16:53

本帖最后由 abc123281 于 2020-2-6 17:05 编辑

确实存在问题，粗心大意造成，已修正

多簿单表查询提取v.rar (18.88 KB, 下载次数: 11)

		自动登录	找回密码
密码			免费注册