ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

   
易厚学堂-专业的职场技能充电站 永久免费,网表让Excel秒变数据库 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel函数公式学习大典 高效办公必会的Office实战技巧 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 ExcelHome出品 - VBA代码宝免费下载 13门Excel免费公开课任你学
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
查看: 169|回复: 11

[求助] 条件判断,有点复杂,实在不会了,求助各位老师帮忙完善。

[复制链接]

TA的精华主题

TA的得分主题

发表于 2018-11-8 23:18 | 显示全部楼层 |阅读模式
条件判断,有点复杂,实在不会了,求助各位老师帮忙完善。如图:
未标题-1 拷贝.jpg
11111.jpg

样本(写入).rar

62.74 KB, 下载次数: 10

TA的精华主题

TA的得分主题

发表于 2018-11-9 08:45 | 显示全部楼层
  1. Sub test()
  2.   Dim r%, i%
  3.   Dim arr, brr
  4.   Dim d As Object
  5.   Set d1 = CreateObject("scripting.dictionary")
  6.   Set d2 = CreateObject("scripting.dictionary")
  7.   With Worksheets("sheet2")
  8.     r = .Cells(.Rows.Count, 2).End(xlUp).Row
  9.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
  10.     arr = .Range("b1").Resize(r, c - 1)
  11.     For i = 2 To UBound(arr)
  12.       xm = arr(i, 1) & "+" & arr(i, 3)
  13.       If Len(xm) <> 0 Then
  14.         d1(xm) = i
  15.       End If
  16.     Next
  17.     For j = 4 To UBound(arr, 2)
  18.       d2(arr(1, j)) = j
  19.     Next
  20.   End With
  21.   With Worksheets("sheet1")
  22.     r = .Range("a1").End(xlDown).Row
  23.     brr = .Range("a1:q" & r)
  24.     For j = 2 To UBound(brr, 2)
  25.       If Len(brr(1, j)) <> 0 Then
  26.         rq = brr(1, j)
  27.       End If
  28.       If d2.exists(rq) Then
  29.         n = d2(rq)
  30.         For i = 3 To UBound(brr)
  31.           If Len(brr(i, j)) <> 0 Then
  32.             xx = Split(brr(i, j), vbLf)
  33.             xm = xx(1) & "+" & xx(0)
  34.             If d1.exists(xm) Then
  35.               m = d1(xm)
  36.               arr(m, n) = brr(i, 1)
  37.             End If
  38.           End If
  39.         Next
  40.       End If
  41.     Next
  42.   End With
  43.   With Worksheets("sheet2")
  44.     .Range("b1").Resize(UBound(arr), UBound(arr, 2)) = arr
  45.   End With
  46. End Sub

复制代码

评分

参与人数 1鲜花 +2 收起 理由
lk2lklk + 2 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

发表于 2018-11-9 08:47 | 显示全部楼层
楼主的流程图制作得很漂亮,意思表达得也很清楚。

样本(写入).rar

165.52 KB, 下载次数: 5

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-11-9 09:58 | 显示全部楼层

大神出手,不同凡响。
是我没有表达清楚,是希望sheet1中[b3]到[q22]的数据所对应的时间,依次填写如sheet2中对应的位置中。如何实现啊?

另外,单独单元格的写入,已经实现。但同样的代码,在2个文件中,一个运行正常,一个出错。也请大神指点学习,代码如下:
  1. Sub 匹配()
  2. Application.ScreenUpdating = False
  3. Dim i, ii, iii, j
  4.    For i = 2 To 22
  5.      m = Cells(i, 22)      '这里Sheet是关键,如果在别的页执行,必须有,否则为当页
  6.      If InStr(Cells(11, 2), m) > 0 Then    '如果提取的数据包含m
  7.       
  8.         For ii = 2 To 8
  9.             n = Cells(ii, 23)
  10.             If InStr(Cells(11, 2), n) > 0 Then
  11.       
  12.                  For iii = 2 To 55
  13.                     If m = Sheet2.Cells(iii, 2) And n = Sheet2.Cells(iii, 4) Then
  14.                         Sheet2.Cells(iii, 9) = Sheet1.Cells(11, 1)  '写入部分
  15.                            
  16.                     End If
  17.                 Next
  18.             End If
  19.         Next
  20.      End If
  21.   Next
  22.    Sheets("Sheet2").Select
  23.          Cells(iii, 9).Select
  24. Application.ScreenUpdating = True
  25. End Sub
复制代码


Desktop.rar

90.69 KB, 下载次数: 0

TA的精华主题

TA的得分主题

发表于 2018-11-9 10:19 | 显示全部楼层
你再看看。

样本(写入).rar

167.86 KB, 下载次数: 9

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-11-9 12:03 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-11-9 12:18 | 显示全部楼层

老师还有问题啊:只能识别2个数据啊(赵六和李四),sheet1添加其他的不写入sheet2 啊,刚刚自学vba,看不太懂老师的代码,无从修改,求助啊

TA的精华主题

TA的得分主题

发表于 2018-11-9 15:39 | 显示全部楼层
lk2lklk 发表于 2018-11-9 12:18
老师还有问题啊:只能识别2个数据啊(赵六和李四),sheet1添加其他的不写入sheet2 啊,刚刚自学vba,看 ...

你把文件传上来呀!不传我怎么知道问题出在哪里了呢?

评分

参与人数 1鲜花 +2 收起 理由
lk2lklk + 2

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-11-9 17:35 | 显示全部楼层
chxw68 发表于 2018-11-9 15:39
你把文件传上来呀!不传我怎么知道问题出在哪里了呢?

谢谢老师,我上传了资料。烦劳您百忙中抽空看看,万分感谢!

Desktop.rar

90.69 KB, 下载次数: 4

TA的精华主题

TA的得分主题

发表于 2018-11-9 20:47 | 显示全部楼层
lk2lklk 发表于 2018-11-9 17:35
谢谢老师,我上传了资料。烦劳您百忙中抽空看看,万分感谢!

文件里的代码不是我写的。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关闭

最新热点上一条 /1 下一条

关注官方微信,每天学会一个新技能

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

GMT+8, 2018-11-15 21:00 , Processed in 0.142834 second(s), 15 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 2001-2017 Wooffice Inc.

   

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

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

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