Excel精英培训网

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

根据日期及姓名查找引用相对应数据

[复制链接]
发表于 2017-5-24 17:39 | 显示全部楼层 |阅读模式
想通过时间及号码,筛选引用当前行的重量。看了很多教程都没有学会,麻烦大神指点一下。

plan.zip

12.28 KB, 下载次数: 10

发表于 2017-5-24 17:59 | 显示全部楼层
  1. Sub ek_sky()
  2.   Dim arr As Variant
  3.   Dim i As Long, j As Long, k As Long, l As Long
  4.     With Sheets("数据表")
  5.       arr = .Range("A2:D" & .Cells(Rows.Count, 1).End(xlUp).Row)
  6.     End With
  7.        For i = 1 To UBound(arr)
  8.          If arr(i, 1) = Range("D1") Then
  9.             If arr(i, 2) = Cells(3, 2) Then
  10.               j = j + 1
  11.               Cells(j + 4, 1) = arr(i, 1)
  12.               Cells(j + 4, 2) = arr(i, 2)
  13.               Cells(j + 4, 3) = arr(i, 3)
  14.               Cells(j + 4, 4) = arr(i, 4)
  15.             ElseIf arr(i, 2) = Cells(3, 7) Then
  16.               k = k + 1
  17.               Cells(k + 4, 6) = arr(i, 1)
  18.               Cells(k + 4, 7) = arr(i, 2)
  19.               Cells(k + 4, 8) = arr(i, 3)
  20.               Cells(k + 4, 9) = arr(i, 4)
  21.             ElseIf arr(i, 2) = Cells(3, 12) Then
  22.               l = l + 1
  23.               Cells(l + 4, 11) = arr(i, 1)
  24.               Cells(l + 4, 12) = arr(i, 2)
  25.               Cells(l + 4, 13) = arr(i, 3)
  26.               Cells(l + 4, 14) = arr(i, 4)
  27.             End If
  28.          End If
  29.        Next i
  30. End Sub
复制代码

评分

参与人数 2 +39 金币 +30 收起 理由
today0427 + 9 哈哈哈,坤哥出山了!
望帝春心 + 30 + 30 来学习,坤哥说好的不会VBA呢

查看全部评分

回复

使用道具 举报

发表于 2017-5-26 10:17 | 显示全部楼层
应该是根据日期自动匹配符合条件的号码,自动生成各表,而不是给定号码填空。
  1. Sub grf()
  2.     Dim CopyRng As Range
  3.     Set d = CreateObject("scripting.dictionary")
  4.     Set CopyRng = Range("a3:d7")
  5.     rq = [d1]
  6.     arr = Sheets("数据表").Range("A2:D" & Sheets("数据表").Cells(Rows.Count, 1).End(xlUp).Row)
  7.     For i = 1 To UBound(arr)
  8.       If arr(i, 1) = rq Then d(arr(i, 2)) = d(arr(i, 2)) & "," & i
  9.     Next
  10.     If d.Count = 0 Then Exit Sub
  11.     For Each x In d.keys
  12.         n = n + 1
  13.         If n > 1 Then CopyRng.Copy Cells(3, 5 * n - 4)
  14.         Cells(3, n * 5 - 3) = x
  15.         xrr = Split(d(x), ",")
  16.         ReDim brr(1 To UBound(xrr), 1 To 4)
  17.         For k = 1 To UBound(xrr)
  18.             For j = 1 To 4
  19.                 brr(k, j) = arr(xrr(k), j)
  20.             Next
  21.         Next
  22.         Cells(5, 5 * n - 4).Resize(k - 1, 4) = brr
  23.     Next
  24. End Sub
复制代码

plan.rar

13.38 KB, 下载次数: 28

评分

参与人数 1 +9 收起 理由
today0427 + 9 老师对论坛是真爱!棒棒哒!

查看全部评分

回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 18:34 , Processed in 0.370985 second(s), 15 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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