|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
- Sub test2()
- Dim r%, i%
- Dim arr, brr
- Dim wb As Workbook
- Dim ws As Worksheet
- Dim mypath$, myname$
- Dim d As Object
- tt = Timer
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Set d = CreateObject("scripting.dictionary")
- Set d1 = CreateObject("scripting.dictionary")
- Set dcs = CreateObject("scripting.dictionary")
- With Worksheets("参数表")
- r = .Cells(.Rows.Count, 2).End(xlUp).Row
- arr = .Range("a1:f" & r)
- For i = 2 To UBound(arr)
- If Len(arr(i, 1)) <> 0 Then
- nj = arr(i, 1)
- End If
- If Not dcs.exists(nj) Then
- Set dcs(nj) = CreateObject("scripting.dictionary")
- End If
- dcs(nj)(arr(i, 2)) = Array(arr(i, 3), arr(i, 4), arr(i, 5), arr(i, 6))
- Next
- End With
- mypath = ThisWorkbook.Path & ""
- myname = Dir(mypath & "*.xls")
- With Worksheets("sheet1")
- c = .Cells(1, .Columns.Count).End(xlToLeft).Column
- bt = .Range("a1").Resize(1, c)
- For j = 1 To UBound(bt, 2)
- d1(bt(1, j)) = j
- Next
- End With
- Do While myname <> ""
- If myname <> ThisWorkbook.Name Then
- Set wb = GetObject(mypath & myname)
- With wb
- With .Worksheets(1)
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- If r > 1 And .Range("a1") = "年级" And d1.exists(.Range("g1").Value) Then
- arr = .Range("a1:g" & r)
- n = d1(arr(1, 7))
- For i = 2 To UBound(arr)
- If Len(arr(i, 3)) <> 0 Then
- If Not d.exists(CStr(arr(i, 3))) Then
- ReDim brr(1 To d1.Count)
- For j = 1 To 6
- brr(j) = arr(i, j)
- Next
- Else
- brr = d(CStr(arr(i, 3)))
- End If
- brr(n) = arr(i, 7)
- d(CStr(arr(i, 3))) = brr
- End If
- Next
- End If
- End With
- .Close False
- End With
- End If
- myname = Dir
- Loop
- With Worksheets("sheet1")
- .UsedRange.Offset(1, 0).Clear
- arr = Application.Transpose(Application.Transpose(d.items))
- For i = 1 To UBound(arr)
- d1.RemoveAll
- If dcs.exists(arr(i, 1)) Then
- For j = 7 To 25 Step 2
- If Len(arr(i, j)) <> 0 Then
- arr(i, 27) = arr(i, 27) + arr(i, j)
- If dcs(arr(i, 1)).exists(bt(1, j)) Then
- brr = dcs(arr(i, 1))(bt(1, j))
- n = 69 - Application.Match(arr(i, j), brr, 1)
- arr(i, j + 1) = Chr(n)
- d1(arr(i, j + 1)) = d1(arr(i, j + 1)) + 1
- End If
- End If
- Next
- End If
- If d1.Count > 0 Then
- ss = ""
- For Each x In Array("A", "B", "C", "D")
- If d1.exists(x) Then
- ss = ss & d1(x) & x
- End If
- Next
- arr(i, 26) = ss
- End If
- Next
- .Range("a2").Resize(UBound(arr), UBound(arr, 2)) = arr
- .Range("a1:ad" & UBound(arr) + 1).Borders.LineStyle = xlContinuous
- Application.ScreenUpdating = True
- MsgBox "数据提取统计完毕!共用时" & Timer - tt & "秒"
- End With
- End Sub
复制代码 |
|