输入批号提取数据

tiantao186

求助做一个查询，输入批号可以提取数据

zldccmx

zldccmx

1. Sub zldccmx()
   
2.     Dim Sh As Worksheet, Arr, Xls, Crr
   
3.     Crr = Sheets("查询").UsedRange
   
4.     Set Xls = GetObject(ThisWorkbook.Path & "\原始表.xls")
   
5.     Application.ScreenUpdating = False
   
6.     Set Sh = Xls.ActiveSheet
   
7.     Arr = Sh.UsedRange
   
8.     Xls.Close False
   
9.     Set Xls = Nothing
   
10.     Sheet2.[A2:D65536] = Empty
    
11.     brr = Sheet2.[A2:D65536]
    
12.     r = 1
    
13.     For j = 2 To UBound(Arr)
    
14.         If Arr(j, 23) = Crr(2, 1) Then
    
15.             brr(r, 1) = Arr(j, 21)
    
16.             brr(r, 2) = Arr(j, 22)
    
17.             brr(r, 3) = Arr(j, 23)
    
18.             brr(r, 4) = Arr(j, 24)
    
19.             r = r + 1
    
20.         End If
    
21.     Next
    
22.     r = r + 1
    
23.     For j = 2 To UBound(Arr)
    
24.         If Arr(j, 30) = Crr(3, 1) Then
    
25.             brr(r, 1) = Arr(j, 25)
    
26.             brr(r, 2) = Arr(j, 29)
    
27.             brr(r, 3) = Arr(j, 30)
    
28.             brr(r, 4) = Arr(j, 31)
    
29.             r = r + 1
    
30.         End If
    
31.     Next
    
32.     Sheet2.[a2].Resize(r - 1, 4) = brr
    
33.     Application.ScreenUpdating = True
    
34.     Sheet2.Activate
    
35. End Sub

复制代码

zldccmx

遍历一次

tiantao186

zldccmx 发表于 2023-2-22 13:26
遍历一次

老师能否发个代码上来

ykcbf1100

参与一下。

ykcbf1100

代码如下：

1. Sub ykcbf()   '//2023.2.22
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim arr, brr(1 To 100000, 1 To 4)
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set sh = Sheets("查询")
   
7.     With sh
   
8.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
   
9.         arr = .Range("a2:a" & r)
   
10.     End With
    
11.     For i = 1 To UBound(arr)
    
12.         d(arr(i, 1)) = arr(i, 1)
    
13.     Next
    
14.     p = ThisWorkbook.Path
    
15.     f = p & "\原始表.xls"
    
16.     n = 4
    
17.     Set wb = Workbooks.Open(f, 0)
    
18.     With wb.Sheets(1)
    
19.         c1 = .[m1].Column: c2 = .[aq1].Column
    
20.         arr = .UsedRange
    
21.         wb.Close False
    
22.     End With
    
23.     For Each k In d.keys
    
24.         For i = 2 To UBound(arr)
    
25.             For j = c1 To 24 Step 4
    
26.                 s = arr(i, j + 2)
    
27.                 If s = k Then
    
28.                     m = m + 1
    
29.                     For x = 1 To 4
    
30.                         brr(m, x) = arr(i, j + x - 1)
    
31.                     Next
    
32.                 End If
    
33.             Next
    
34.             For j = 26 To c2 Step 3
    
35.                 s = arr(i, j + 1)
    
36.                 If s = k Then
    
37.                     m = m + 1
    
38.                     brr(m, 1) = arr(i, 25)
    
39.                     For x = 2 To 4
    
40.                         brr(m, x) = arr(i, j + x - 2)
    
41.                     Next
    
42.                 End If
    
43.             Next
    
44.         Next
    
45.         m = m + 1
    
46.     Next
    
47.     With Sheets("样表")
    
48.         .UsedRange.Offset(1).Clear
    
49.         .[a2].Resize(m, 4) = brr
    
50.         .[a2].Resize(m, 4).Borders.LineStyle = 1
    
51.     End With
    
52.     Application.ScreenUpdating = True
    
53. End Sub
    

复制代码

tiantao186

ykcbf1100 发表于 2023-2-22 14:47
参与一下。

老师，能否增加个遍历文件夹功能

ykcbf1100

tiantao186 发表于 2023-2-22 15:25
老师，能否增加个遍历文件夹功能

遍历文件夹提取数据。

tiantao186

ykcbf1100 发表于 2023-2-22 16:07
遍历文件夹提取数据。

老师，请问怎么能去掉星期，只显示日期