ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 1742|回复: 12

[已解决] 提取数据的问题

[复制链接]

TA的精华主题

TA的得分主题

发表于 2017-9-24 09:43 | 显示全部楼层 |阅读模式
本帖最后由 dfshm 于 2017-9-24 15:30 编辑

附件 按要求提取数据附件.rar (162.75 KB, 下载次数: 4)
谢谢老师!
能在64位 office中运行

TA的精华主题

TA的得分主题

发表于 2017-9-24 09:50 来自手机 | 显示全部楼层
留下脚印先。。。。。。

TA的精华主题

TA的得分主题

发表于 2017-9-24 10:17 | 显示全部楼层
那些若干工作簿,我就不信你实际数据第一行无表头而直接就是数据?你已经是铁杆提问者了,应该说不应该模拟这种“垃圾表”!!!

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-9-24 11:36 | 显示全部楼层
duquancai 发表于 2017-9-24 10:17
那些若干工作簿,我就不信你实际数据第一行无表头而直接就是数据?你已经是铁杆提问者了,应该说不应该模拟 ...

谢谢关注。你说的没错。但如果A列多出一列,会使工作薄的大小增加15M左右。这会给后续的读取数据增加困难。因此,让VBA自动识别序号,使电脑不致于工作薄文件太大而变慢。

实际数据,一张工作薄有39M,共980张工作薄。如果每张多出一列A,可以想象会增加多大麻烦。

TA的精华主题

TA的得分主题

发表于 2017-9-24 12:00 | 显示全部楼层
本帖最后由 duquancai 于 2017-9-24 12:32 编辑

Sub shishi()
    Dim d As Object, w As Workbook, f$, ph$, arr, brr(1 To 1000, 1 To 8)
    ph = ThisWorkbook.Path
    k1 = "'" & [h1]: k2 = "'" & [h2]: k3 = [i1]: k4 = [i2]
    f = Dir(ph & "\" & "*.xls*")
    Set d = CreateObject("Scripting.Dictionary")
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            Set w = GetObject(ph & "\" & f)
            arr = w.Sheets(1).Range("a1:g" & w.Sheets(1).Cells(w.Sheets(1).Rows.Count, "g").End(3).Row)
            d.RemoveAll
            For i = 1 To UBound(arr)
                If Not d.exists("'" & arr(i, 7)) Then
                    d("'" & arr(i, 7)) = i
                Else
                    d("'" & arr(i, 7)) = d("'" & arr(i, 7)) & "," & i
                End If
            Next
            w.Close 0
            If d.exists(k1) And d.exists(k2) Then
                y1 = Split(d(k1), ","): y2 = Split(d(k2), ",")
                For m = 0 To UBound(y2)
                    For n = 0 To UBound(y1)
                        s1 = 0: s2 = 0
                        If y2(m) - y1(n) = 1 Then
                            For r = 1 To UBound(arr, 2) - 1
                                s1 = s1 + arr(y1(n), r)
                                s2 = s2 + arr(y2(m), r)
                            Next
                            If s1 = k3 And s2 = k4 Then
                                x = x + 2
                                For g = 1 To UBound(arr, 2) - 1
                                    brr(x - 1, g) = arr(y1(n), g)
                                    brr(x - 1, 7) = f: brr(x - 1, 8) = y1(n)
                                    brr(x, g) = arr(y2(m), g)
                                    brr(x, 7) = f: brr(x, 8) = y2(m)
                                Next
                            End If
                        End If
                    Next
                Next
            End If
        End If
        f = Dir
    Loop
    Range("s1").Resize(1000, 8) = brr
End Sub

TA的精华主题

TA的得分主题

发表于 2017-9-24 12:08 | 显示全部楼层
本帖最后由 duquancai 于 2017-9-24 12:33 编辑
duquancai 发表于 2017-9-24 10:17
那些若干工作簿,我就不信你实际数据第一行无表头而直接就是数据?你已经是铁杆提问者了,应该说不应该模拟 ...

打开附件,点击按钮》》》》》》》》》》》》》》

按要求提取数据附件.rar

176.62 KB, 下载次数: 9

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-9-24 16:20 | 显示全部楼层
考虑到你的数据量很大,这题目,我可能搞复杂了,应该用自定义数据类型,采购顺序表结构 估计速度要快一些,等我有空写写代码,你再测试一下

TA的精华主题

TA的得分主题

发表于 2017-9-24 16:51 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 duquancai 于 2017-9-24 16:53 编辑

我用自定义数据类型,取消了字典,又写一个,由于没有大数据的测试,不知道这两种谁快?
你测试一下》》》》》》》》》》》》》》》》》》》》》》》》》
Type nods
    p As Long
    A As Double
    B As Double
End Type
Sub shishi()
    Dim w As Workbook, f$, ph$, arr, NodArr() As nods, brr(1 To 1000, 1 To 8)
    ph = ThisWorkbook.Path
    k1 = [h1]: k2 = [h2]: k3 = [i1]: k4 = [i2]
    f = Dir(ph & "\" & "*.xls*")
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            Set w = GetObject(ph & "\" & f)
            arr = w.Sheets(1).Range("a1:g" & w.Sheets(1).Cells(w.Sheets(1).Rows.Count, "g").End(3).Row)
            w.Close 0
            ReDim NodArr(1 To UBound(arr) - 1)
            For i = 1 To UBound(arr) - 1
                NodArr(i).p = i
                NodArr(i).A = arr(i, 7)
                NodArr(i).B = arr(i + 1, 7)
            Next
            For i = 1 To UBound(arr) - 1
                With NodArr(i)
                    s1 = 0: s2 = 0
                    If .A = k1 And .B = k2 Then
                        For j = 1 To 6
                            s1 = s1 + arr(.p, j)
                            s2 = s2 + arr(.p + 1, j)
                        Next
                        If s1 = k3 And s2 = k4 Then
                            x = x + 2
                            For g = 1 To 6
                                brr(x - 1, g) = arr(.p, g)
                                brr(x - 1, 7) = f: brr(x - 1, 8) = .p
                                brr(x, g) = arr(.p + 1, g)
                                brr(x, 7) = f: brr(x, 8) = .p + 1
                            Next
                        End If
                    End If
                End With
            Next
        End If
        f = Dir
    Loop
    Range("s1").Resize(1000, 8) = brr
End Sub

自定义数据类型提取数据.rar

173.65 KB, 下载次数: 4

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-9-24 17:21 | 显示全部楼层
duquancai 发表于 2017-9-24 16:51
我用自定义数据类型,取消了字典,又写一个,由于没有大数据的测试,不知道这两种谁快?
你测试一下》》》 ...

谢谢老师。这个快多了。另外,返回的结果,只要第一行即可。如下图,取标色一行即可。
TIM图片20170924171448.jpg

TA的精华主题

TA的得分主题

发表于 2017-9-24 17:28 | 显示全部楼层
本帖最后由 duquancai 于 2017-9-24 17:32 编辑

Type nods
    p As Long
    A As Double
    B As Double
End Type
Sub 第三版()
    Dim w As Workbook, f$, ph$, arr, NodArr() As nods, d As Object, brr(1 To 1000, 1 To 8)
    ph = ThisWorkbook.Path
    k1 = [h1]: k2 = [h2]: k3 = [i1]: k4 = [i2]
    f = Dir(ph & "\" & "*.xls*")
    Set d = CreateObject("Scripting.Dictionary")
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            Set w = GetObject(ph & "\" & f)
            arr = w.Sheets(1).Range("a1:g" & w.Sheets(1).Cells(w.Sheets(1).Rows.Count, "g").End(3).Row)
            w.Close 0: d.RemoveAll
            ReDim NodArr(1 To UBound(arr) - 1)
            For i = 1 To UBound(arr) - 1
                With NodArr(i)
                    .p = i: .A = arr(i, 7): .B = arr(i + 1, 7)
                    d(.A & "|" & .B) = .p
                End With
            Next
            If d.exists(k1 & "|" & k2) Then
                With NodArr(d(k1 & "|" & k2))
                    s1 = 0: s2 = 0
                    For j = 1 To 6
                        s1 = s1 + arr(.p, j)
                        s2 = s2 + arr(.p + 1, j)
                    Next
                    If s1 = k3 And s2 = k4 Then
                        x = x + 1
                        For g = 1 To 6
                            brr(x, g) = arr(.p, g)
                            brr(x, 7) = f: brr(x, 8) = .p
                        Next
                    End If
                End With
            End If
        End If
        f = Dir
    Loop
    Range("s1").Resize(1000, 8) = brr
End Sub
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-28 22:13 , Processed in 0.056018 second(s), 11 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表