Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2418|回复: 9

[已解决]请教高手,数据处理(见附件,有详细说明)

[复制链接]
发表于 2017-6-9 12:14 | 显示全部楼层 |阅读模式
本帖最后由 斜阳几度 于 2017-6-10 11:14 编辑

由于数据量大,真的无法用函数完成。以下说明,另见附件!
请各位高手帮助解决。

说明:
    所有数据都是1或者2。A列数据15万个,B列数据25个。
    判断B1:B25单元格(25个单元格)是否与A1:A25单元格(25个单元格)值完全相等,如不等,则判断B1:B25是否与A2:A26单元格数据完全相等,依次判断,程序执行到A149993行(相当于函数里面的下拉),如B1:B25单元格与A1:A25单元格相等,则将A26:A32单元格(7个单元格)值分别返回到E1:K1中,同时将A26的行数值返回到D1。这样一条信息采集完成,如有多个满足条件的信息,只采集三条信息后退出程序。如果只有一条信息满足条件,则采集完成后,程序结束。
    如果以上未找到符合条件的信息,则判断B2:B25单元格(24个单元格)是否与A1:A24单元格(24个单元格)值完全相等,程序执行到A149993,如
B2:B25单元格与A1:A24单元格完全相等,则将A25:A31单元格(7个单元格)值分别返回到E5:K5中,同时将A25的行数值返回到D5。同上,只采集三条,如只有一条,采集后程序结束。
(以下类推:)
    如未找到,则判断B3:B25单元格与A1:A23(如相等则将A24:A30返回到E9:K9,将A24的行数值返回到D9)......
    如未找到,则判断B4:B25单元格与A1:A22(如相等则将A23:A29返回到E13:K13,将A23的行数值返回到D13)......
    如未找到,则判断B5:B25单元格与A1:A21(如相等则将A22:A28返回到E17:K17,将A22的行数值返回到D17)......
    如以上均未找到,程序结束。
    有20张这样的完全一样的工作表,只是数据不同,运行一次,对20张工作表完成采集。

    如果用函数,那可真是杯具了~~~~还求大神用VBA帮助解决。
                                                                                           斜阳几度在此谢过!!!
    本表版本为 excel 2013 由于数据关系,无法使用2003版。
最佳答案
2017-6-9 14:16
  1. Sub tt()
  2.     Dim Flg As Boolean
  3.     arr = Range("a1:a150000")
  4.     Dim xrr(1 To 3, 1 To 8)
  5.     [d:k].ClearContents
  6.     For k = 1 To 24
  7.         If n > 0 Then Exit For   '如果上一组已有比较结果,则结束
  8.         brr = Range(Cells(k, 2), Cells(25, 2))    '本组待比较的数据
  9.         n = 0   '本组比较开始
  10.         For i = 1 To UBound(arr) - k - 24
  11.             If n = 3 Then Exit For    '如果本组有三个结果,结束
  12.             Flg = True
  13.             For kk = 1 To 26 - k
  14.                 If arr(i + kk - 1, 1) <> brr(kk, 1) Then Flg = False: Exit For
  15.             Next
  16.             If Flg Then
  17.                 n = n + 1
  18.                 p = i + kk - 1
  19.                 xrr(n, 1) = p
  20.                 For kk = 2 To 8
  21.                     xrr(n, kk) = arr(p + kk - 2, 1)
  22.                 Next
  23.             End If
  24.         Next
  25.     Next
  26.     msg = IIf(n > 0, "比对数据长度:" & 27 - k, "比较失败,无匹配结果")
  27.     If n > 0 Then Cells(k * 4 - 7, 4).Resize(n, 8) = xrr
  28.     MsgBox msg
  29. End Sub
复制代码

数据采集(版本excel 2013).rar

443.32 KB, 下载次数: 7

发表于 2017-6-9 13:40 | 显示全部楼层
  1. Sub conpare()
  2. Dim arr, brr, crr, n$, m$, i%, j As Long
  3. For i = 1 To 5
  4.     brr = Cells(i, 2).Resize(26 - i)
  5.     m = Join(Application.WorksheetFunction.Transpose(brr), "")
  6.     For j = 1 To 149993 - 25 + i
  7.             arr = Cells(j, 1).Resize(26 - i)
  8.             n = Join(Application.WorksheetFunction.Transpose(arr), "")
  9.             If m = n Then
  10.                 x = x + 1
  11.                 crr = Cells(j, 1).Offset(26 - i).Resize(7)
  12.                 Cells(i * 4 - 4 + x, 5).Resize(1, 7) = Application.WorksheetFunction.Transpose(crr)
  13.                 If x = 3 Then Exit Sub
  14.             End If
  15.     Next j
  16.     If x <> 0 Then Exit Sub
  17. Next i
  18. End Sub
复制代码

数据采集(版本excel 2013).rar

482.11 KB, 下载次数: 11

回复

使用道具 举报

发表于 2017-6-9 14:16 | 显示全部楼层    本楼为最佳答案   
  1. Sub tt()
  2.     Dim Flg As Boolean
  3.     arr = Range("a1:a150000")
  4.     Dim xrr(1 To 3, 1 To 8)
  5.     [d:k].ClearContents
  6.     For k = 1 To 24
  7.         If n > 0 Then Exit For   '如果上一组已有比较结果,则结束
  8.         brr = Range(Cells(k, 2), Cells(25, 2))    '本组待比较的数据
  9.         n = 0   '本组比较开始
  10.         For i = 1 To UBound(arr) - k - 24
  11.             If n = 3 Then Exit For    '如果本组有三个结果,结束
  12.             Flg = True
  13.             For kk = 1 To 26 - k
  14.                 If arr(i + kk - 1, 1) <> brr(kk, 1) Then Flg = False: Exit For
  15.             Next
  16.             If Flg Then
  17.                 n = n + 1
  18.                 p = i + kk - 1
  19.                 xrr(n, 1) = p
  20.                 For kk = 2 To 8
  21.                     xrr(n, kk) = arr(p + kk - 2, 1)
  22.                 Next
  23.             End If
  24.         Next
  25.     Next
  26.     msg = IIf(n > 0, "比对数据长度:" & 27 - k, "比较失败,无匹配结果")
  27.     If n > 0 Then Cells(k * 4 - 7, 4).Resize(n, 8) = xrr
  28.     MsgBox msg
  29. End Sub
复制代码

数据采集(版本excel 2013).rar

482.12 KB, 下载次数: 17

回复

使用道具 举报

 楼主| 发表于 2017-6-9 14:31 | 显示全部楼层

你好  感谢您为我编写的代码  我刚才做了测试  没有行数  同时速度特别慢。同时也对楼下朋友的代码做了测试  速度真的特别快 。

对于我这个不懂VBA的人来说,你们就是我的神啊!!

再次感谢朋友的帮助,感激不尽!!
回复

使用道具 举报

 楼主| 发表于 2017-6-9 14:34 | 显示全部楼层

grf1973    谢谢您的帮助


对您的代码我做了测试  速度真是秒快啊   ,太完美的作品!


在此感激!!!
再次感谢!!!


真的解决我的大问题!!!
回复

使用道具 举报

发表于 2017-6-9 14:41 | 显示全部楼层
用字符串比较也行,速度稍微慢一点。
  1. Sub tt()
  2.     Dim L
  3.     arr = Range("a1:a150000")
  4.     For i = 1 To UBound(arr)    '15万数据组成字符串
  5.         x = x & arr(i, 1)
  6.     Next
  7.     Dim xrr(1 To 3, 1 To 8)
  8.     [d:k].ClearContents
  9.     For k = 1 To 24
  10.         If n > 0 Then Exit For   '如果上一组已有比较结果,则结束
  11.         L = 26 - k
  12.         y = Join(Application.Transpose(Range(Cells(k, 2), Cells(25, 2))), "")     '本组待比较的字符串
  13.         n = 0   '本组比较开始
  14.         tmp = 1
  15.         For m = 1 To 3   '最多比较3次
  16.             p = InStr(tmp, x, y)     '字符串x,从位置tmp开始,是否存在字符串y
  17.             If p = 0 Then Exit For
  18.             n = n + 1
  19.             xrr(n, 1) = p + L
  20.             For kk = 2 To 8
  21.                 xrr(n, kk) = arr(p + L + kk - 2, 1)
  22.             Next
  23.             tmp = p + 1
  24.         Next
  25.     Next
  26.     msg = IIf(n > 0, "比对数据长度:" & 27 - k, "比较失败,无匹配结果")
  27.     If n > 0 Then Cells(k * 4 - 7, 4).Resize(n, 8) = xrr
  28.     MsgBox msg
  29. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2017-6-9 16:09 | 显示全部楼层
本帖最后由 斜阳几度 于 2017-6-9 16:14 编辑
grf1973 发表于 2017-6-9 14:41
用字符串比较也行,速度稍微慢一点。

grf1973  您好!  非常感谢!!!


      我对您刚才的代码测试了一下,虽然没有刚才的快,但是已经很快了。就是能不能让他不弹出对话框,每次要确定以后才能进行下次操作。由于工作表太多,要逐一确定,无法操作。还请您帮助把这两次编写的代码修改一下 ,取消自动弹出对话框。


       您对我的帮助真的是深表谢意!看你的注册名字  我们应该是同代人   我是1970    
回复

使用道具 举报

发表于 2017-6-9 16:14 | 显示全部楼层
把 msgbox msg 那句删掉即可。
回复

使用道具 举报

 楼主| 发表于 2017-6-9 16:25 | 显示全部楼层
grf1973 发表于 2017-6-9 16:14
把 msgbox msg 那句删掉即可。

grf1973  你好 !!!

大大的感谢   

  太完美了!!



  msg = IIf(n > 0, "比对数据长度:" & 27 - k, "比较失败,无匹配结果")
    If n > 0 Then Cells(k * 4 - 7, 4).Resize(n, 8) = xrr
    MsgBox msg




以上三行代码,我删除了上下两行,保留了中间行,运行后正是我要的效果,不知道我做的对不对。




回复

使用道具 举报

发表于 2017-6-9 19:56 | 显示全部楼层
对的,没错。
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 20:08 , Processed in 0.647191 second(s), 11 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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