VBA 数据统计问题求助

baofa2

1. Sub test1()
   
2.   Dim ar(1 To 666, 1 To 3), br, cr, dict As Object
   
3.   Dim strPath As String, strFile As String, LOT As String
   
4.   Dim i As Long, j As Long, k As Variant
   
5.   
   
6.   Application.ScreenUpdating = False
   
7.   
   
8.   i = 1
   
9.   ar(i, 1) = "LOT"
   
10.   ar(i, 2) = "Vge"
    
11.   ar(i, 3) = "lcsc"
    
12.   
    
13.   Set dict = CreateObject("Scripting.Dictionary")
    
14.   
    
15.   strPath = ThisWorkbook.Path & "\"
    
16.   strFile = Dir(strPath & "*_SCA_HS.CSV")
    
17.   Do
    
18.     br = Split(strFile, "_")
    
19.     LOT = br(0) & "_" & br(1)
    
20.     If Not dict.Exists(LOT) Then
    
21.       dict.Add LOT, Array(strFile, Val(br(2)))
    
22.     Else
    
23.       cr = dict(LOT)
    
24.       If Val(br(2)) > cr(1) Then dict(LOT) = Array(strFile, Val(br(2)))
    
25.     End If
    
26.     strFile = Dir
    
27.   Loop While Len(strFile)
    
28.   
    
29.   For Each k In dict.Keys
    
30.     i = i + 1
    
31.     ar(i, 1) = k
    
32.     br = Split(ReadUTFText(strPath & dict(k)(0)), vbCrLf)
    
33.     For j = 0 To UBound(br)
    
34.       If Val(br(j)) > 1.2 Then
    
35.         cr = Split(br(j), vbTab)
    
36.         ar(i, 2) = cr(1)
    
37.         ar(i, 3) = cr(3)
    
38.         Exit For
    
39.       End If
    
40.     Next
    
41.   Next
    
42.   
    
43.   With Sheet2
    
44.     .Cells.ClearContents
    
45.     .Range("A1").Resize(i, UBound(ar, 2)) = ar
    
46.   End With
    
47.   
    
48.   Set dict = Nothing
    
49.   Application.ScreenUpdating = True
    
50.   Beep
    
51. End Sub
    
52. 
    
53. Function ReadUTFText(ByVal strFullName As String) As String
    
54.   With CreateObject("ADODB.Stream")
    
55.     .Type = 2
    
56.     .Mode = 3
    
57.     .Open
    
58.     .LoadFromFile strFullName
    
59.     .Charset = "UTF-8"
    
60.     .Position = 2
    
61.     ReadUTFText = .ReadText
    
62.     .Close
    
63.   End With
    
64. End Function

复制代码

nemenis

半百 发表于 2024-4-12 12:35
不知猜的对不对

是对的，但好像会出现编译错误

nemenis

baofa2 发表于 2024-4-12 12:38

大佬，您答复的VBA程序中这句话含义一直没理解，所以冒昧请大佬帮忙解释一下
大佬，您发给我的VBA程序中有一句一直看不太懂，只能冒昧再打扰您一下
br = Split(ReadUTFText(strPath & dict(k)(0)), vbCrLf)

baofa2

nemenis 发表于 2024-4-15 23:06
大佬，您答复的VBA程序中这句话含义一直没理解，所以冒昧请大佬帮忙解释一下
大佬，您发给我的VBA程序中 ...

yynrzwh

data.zip (354.79 KB, 下载次数: 8)

2024-4-16 10:38 上传

点击文件名下载附件

nemenis

baofa2 发表于 2024-4-16 08:08

终于看懂了大佬这个写法，简洁且运行速度很快！

就是有个小问题，第三列Icsc不是取第一列大于1.2的行对应第四列的数据，而是要取第四列所有数据中最大的那个，这样的话请教应该如何改进代码？按照大佬这个架构有点下不去手

baofa2

nemenis 发表于 2024-4-16 21:50
终于看懂了大佬这个写法，简洁且运行速度很快！

就是有个小问题，第三列Icsc不是取第一列大于1.2的行 ...

1.   For Each k In dict.Keys
   
2.     i = i + 1
   
3.     ar(i, 1) = k
   
4.     ar(i, 3) = 0
   
5.     br = Split(ReadUTFText(strPath & dict(k)(0)), vbCrLf)
   
6.     For j = 0 To UBound(br)
   
7.       If Val(br(j)) <> 0 Then    ' >1.2   
   
8.         cr = Split(br(j), vbTab)
   
9.         If Val(cr(3)) > ar(i, 3) Then
   
10.           ar(i, 2) = cr(1)
    
11.           ar(i, 3) = Val(cr(3))
    
12.         End If
    
13.       End If
    
14.     Next
    
15.   Next

复制代码

ykcbf1100

凑个热闹，附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.17
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Set sh = ThisWorkbook.Sheets("sum")
   
6.     p = ThisWorkbook.Path & ""
   
7.     st = "SCA_HS"
   
8.     For Each f In fso.GetFolder(p).Files
   
9.         If InStr(f.Name, st) Then
   
10.             st1 = Split(fso.GetBaseName(f), "_")
    
11.             lot = st1(0) & "_" & st1(1)
    
12.             k = st1(2)
    
13.             If Not d.exists(lot) Then
    
14.                 d(lot) = Array(k, lot, f.Path)
    
15.             Else
    
16.                 t = d(lot)
    
17.                 t(0) = IIf(k < t(0), t(0),k)
    
18.                 d(lot) = t
    
19.             End If
    
20.         End If
    
21.     Next f
    
22.     ReDim brr(1 To d.Count, 1 To 3)
    
23.     On Error Resume Next
    
24.     For Each k In d.keys
    
25.         m = m + 1
    
26.         brr(m, 1) = d(k)(1)
    
27.         Set wb = Workbooks.Open(d(k)(2), 0)
    
28.         arr = wb.Sheets(1).UsedRange
    
29.         wb.Close 0
    
30.         For i = 7 To UBound(arr)
    
31.             b = Split(arr(i, 1), "-")
    
32.             If Val(b(0)) > 1.2 Then
    
33.                 brr(m, 2) = Val(b(0))
    
34.                 Exit For
    
35.             End If
    
36.         Next
    
37.         Max = 0
    
38.         For i = 7 To UBound(arr)
    
39.             b = Split(arr(i, 1), "-")
    
40.             If Val(b(2)) > Max Then Max = Val(b(2))
    
41.         Next
    
42.         brr(m, 3) = Max
    
43.     Next
    
44.     With sh
    
45.         .UsedRange.Offset(1) = ""
    
46.         .[a1].Resize(1, 3).Interior.Color = 49407
    
47.         .[a2].Resize(m, 3) = brr
    
48.     End With
    
49.     Application.ScreenUpdating = True
    
50.     MsgBox "OK！"
    
51. End Sub
    

复制代码