VBA 按条件查找并返回对应格式内容

hyjianjian

大侠们：

您好！
              附件里有2个工作簿  
              1：返回工作簿 （sheet1 A列为 需要查找的数值    sheet2  为返回数值！）
              2：查找工作簿（范围sheet2   ）
查找工作簿  格式特性   小题行固定   A~R 列   列数固定 ！ 需要获取最大行数 变量！

查找逻辑 ：

F列 是匹配对应的列数

C列 是它的等级  （0~11）  0 最大   11 最小！

根据  返回工作簿 sheet1 A列搜索对应匹配的F列 （查找工作簿sheet2 ）   再依据搜索到的C列  自身的等级 ， 向下查找 并返回符合的 C~R列信息！（返回工作簿  sheet2）

遇到C列为0阶则停止！（不包含0阶）

例子： 根据返回工作簿 （sheet1 A列为 需要查找的数值） 去 查找工作簿（范围sheet2   ）F列匹配的数值    判断其 C列的值 （如果为0  任意均可）   以C列 向下查找  依次返回  0（自身） 8，7，6，5，4，3，2，1。 遇到0则结束！（向下查找时不返回C列0）   

（在返回工作簿sheet2 返回 C~R列内容）

（I列大于0）  且   （M列为S*开头）  必须同时符合这两条件内容才返回！

请注意  在查找工作簿  sheet2 返回值时候的格式！ 能够明显区分出 不同查找值！结束行带颜色。

  

附件带查找227457-5200例子！

hyjianjian

如有表述不清，可提出。恳请协助

蓝桥玄霜

请见代码。

hyjianjian

蓝桥玄霜 发表于 2015-12-31 11:33
请见代码。

蓝版主，感谢您协助。可以给个文字版本代码吗？现在的是图片。

yu2800

学习了。。。。。。。。。

hyjianjian

蓝桥玄霜 发表于 2015-12-31 11:33
请见代码。

蓝版：代码报错，“13”错误代码  类型不匹配。 Cells(n, 1).Resize(1, UBound(arr, 2)) = Application.Index(arr, ks, 0)
恳请指正

1. Sub l2()
   
2. Dim myPath$, myName$, arr1(), r%, aa, j&, ks, js
   
3. Dim arr, i&, cz, n&, ii&, d, t
   
4. Application.ScreenUpdating = False
   
5. Set d = CreateObject("scripting.dictionary")
   
6. Sheet2.Activate: Cells.Clear
   
7. mypath = ThisWorkbook.Path & ""
   
8. myName = "号口车种.xls"
   
9. With GetObject(mypath & myName)
   
10.    arr = .Sheets(2).UsedRange
    
11.    For i = 2 To UBound(arr)
    
12.          If arr(i, 3) = 0 Then
    
13.          r = r + 1
    
14.          ReDim Preserve arr1(1 To r)
    
15.          arr1(r) = i
    
16.          d(arr(i, 6)) = d(arr(i, 6)) & r & ","
    
17.          End If
    
18.     Next
    
19.     .Close False
    
20. End With
    
21. cz = Sheet1.[a1].CurrentRegion
    
22. For ii = 2 To UBound(cz)
    
23.       n = n + 1
    
24.       Cells(n, 1) = cz(ii, 1)
    
25.       If d.exists(cz(ii, 1)) Then
    
26.            t = d(cz(ii, 1))
    
27.            t = Left(t, Len(t) - 1)
    
28.       If InStr(t, ",") Then
    
29.       aa = Split(t, ",")
    
30.       For j = 0 To UBound(aa)
    
31.               If Val(aa(j)) <> r Then
    
32.               js = arr1(Val(aa(j)) + 1) - 1
    
33.            Else
    
34.               js = UBound(arr)
    
35.            End If
    
36.            ks = arr1(Val(aa(j)))
    
37.             n = n + 1
    
38.             Cells(n, 1).Resize(1, UBound(arr, 2)) = Application.Index(arr, ks, 0)
    
39.             For i = ks + 1 To js
    
40.             If Left(arr(i, 13), 1) = "S*" And arr(i, 9) > 0 Then
    
41.             n = n + 1
    
42.             Cells(n, 1).Resize(1, UBound(arr, 2)) = applecation.Index(arr, i, 0)
    
43.             End If
    
44.          Next
    
45.        Next
    
46.      Else
    
47.         If t <> r Then
    
48.             js = arr1(t + 1) - 1
    
49.         Else
    
50.             js = UBound(arr)
    
51.         End If
    
52.         ks = arr1(t)
    
53.                 n = n + 1
    
54.                 Cells(n, 1).Resize(1, UBound(arr, 2)) = Application.Index(arr, ks, 0)
    
55.         For i = ks + 1 To js
    
56.         If Left(arr(i, 13), 1) = "S*" And arr(i, 9) > 0 Then
    
57.              n = n + 1
    
58.              Cells(n, 1).Resize(1, UBound(arr, 2)) = Application.Index(arr, i, 0)
    
59.           End If
    
60.       Next
    
61.    End If
    
62. End If
    
63. Cells(n, 1).Resize(1, UBound(arr, 2)).Interior.ColorIndex = 4
    
64. Next
    
65. Application.ScreenUpdating = trus
    
66. End Sub

复制代码

蓝桥玄霜

有没有抄错的地方？

1. Sub lqxs()
   
2. Dim myPath$, myName$, Arr1(), r%, aa, j&, ks, js
   
3. Dim Arr, i&, cz, n&, ii&, d, t
   
4. Application.ScreenUpdating = False
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. Sheet2.Activate: Cells.Clear
   
7. myPath = ThisWorkbook.Path & ""
   
8. myName = "查找工作簿.xlsx"
   
9. With GetObject(myPath & myName)
   
10.     Arr = .Sheets(2).UsedRange
    
11.     For i = 2 To UBound(Arr)
    
12.         If Arr(i, 3) = 0 Then
    
13.             r = r + 1
    
14.             ReDim Preserve Arr1(1 To r)
    
15.             Arr1(r) = i
    
16.             d(Arr(i, 6)) = d(Arr(i, 6)) & r & ","
    
17.         End If
    
18.     Next
    
19.     .Close False
    
20. End With
    
21. cz = Sheet1.[a1].CurrentRegion
    
22. For ii = 2 To UBound(cz)
    
23.     n = n + 1
    
24.     Cells(n, 1) = cz(ii, 1)
    
25.     If d.exists(cz(ii, 1)) Then
    
26.         t = d(cz(ii, 1))
    
27.         t = Left(t, Len(t) - 1)
    
28.         If InStr(t, ",") Then
    
29.             aa = Split(t, ",")
    
30.             For j = 0 To UBound(aa)
    
31.                 If Val(aa(j)) <> r Then
    
32.                     js = Arr1(Val(aa(j)) + 1) - 1
    
33.                 Else
    
34.                     js = UBound(Arr)
    
35.                 End If
    
36.                 ks = Arr1(Val(aa(j)))
    
37.                     n = n + 1
    
38.                     Cells(n, 1).Resize(1, UBound(Arr, 2)) = Application.Index(Arr, ks, 0)
    
39.                 For i = ks + 1 To js
    
40.                     If Left(Arr(i, 13), 1) = "S" And Arr(i, 9) > 0 Then
    
41.                         n = n + 1
    
42.                         Cells(n, 1).Resize(1, UBound(Arr, 2)) = Application.Index(Arr, i, 0)
    
43.                     End If
    
44.                 Next
    
45.             Next
    
46.         Else
    
47.             If t <> r Then
    
48.                 js = Arr1(t + 1) - 1
    
49.             Else
    
50.                 js = UBound(Arr)
    
51.             End If
    
52.             ks = Arr1(t)
    
53.                     n = n + 1
    
54.                     Cells(n, 1).Resize(1, UBound(Arr, 2)) = Application.Index(Arr, ks, 0)
    
55.             For i = ks + 1 To js
    
56.                 If Left(Arr(i, 13), 1) = "S" And Arr(i, 9) > 0 Then
    
57.                     n = n + 1
    
58.                     Cells(n, 1).Resize(1, UBound(Arr, 2)) = Application.Index(Arr, i, 0)
    
59.                 End If
    
60.             Next
    
61.         End If
    
62.     End If
    
63.     Cells(n, 1).Resize(1, UBound(Arr, 2)).Interior.ColorIndex = 4
    
64. Next
    
65. Application.ScreenUpdating = True
    
66. End Sub
    

复制代码

hyjianjian

蓝桥玄霜 发表于 2016-1-1 10:45
有没有抄错的地方？

蓝版主，感谢您再次协助！代码成功扩展应用于别的数据源。

补充下记2个请求：

1：当返回工作簿 sheet1 A列搜索对应匹配的F列 （查找工作簿sheet2 ）时，查找工作簿sheet2里出现多条重复数据时候，我想加入只搜索一次限制。以查找工作簿sheet2的行数为（行数小的）优先顺序、逻辑跟条件不变，向下查找遇到C列为0时结束。结束后不再查找。

2：在返回结果里，A列套入一条公式 VLOOKUP(H2,Sheet3!A:C,3,0)

hyjianjian

蓝桥玄霜 发表于 2016-1-1 10:45
有没有抄错的地方？

蓝版主，如果我想加入一句限制语句。当“查找工作簿（范围sheet2   ）F列匹配的数值”出现多个符合项目时，只查找一次既第一个出现的，按要求返回。后续符合选项不需要再次查找。如何加入？

蓝桥玄霜

在第44行下面加一句：
Exit For