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

lk2lklk

条件判断，有点复杂，实在不会了，求助各位老师帮忙完善。如图：

chxw68

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
    
47. 
    

复制代码

chxw68

楼主的流程图制作得很漂亮，意思表达得也很清楚。

lk2lklk

chxw68 发表于 2018-11-9 08:45

大神出手，不同凡响。
是我没有表达清楚，是希望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

复制代码

chxw68

你再看看。

lk2lklk

chxw68 发表于 2018-11-9 10:19
你再看看。

这会正确运行了，谢谢老师

lk2lklk

chxw68 发表于 2018-11-9 10:19
你再看看。

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

chxw68

lk2lklk 发表于 2018-11-9 12:18
老师还有问题啊：只能识别2个数据啊（赵六和李四），sheet1添加其他的不写入sheet2 啊，刚刚自学vba，看 ...

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

lk2lklk

chxw68 发表于 2018-11-9 15:39
你把文件传上来呀！不传我怎么知道问题出在哪里了呢？

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

chxw68

lk2lklk 发表于 2018-11-9 17:35
谢谢老师，我上传了资料。烦劳您百忙中抽空看看，万分感谢！

文件里的代码不是我写的。