|
- Sub 整理2()
- Dim iSheetNumber As Integer
- Dim lLastRow&, i As Long, lRecord As Long, j As Long, k As Long
- Dim objDic1 As Object, objDic2 As Object, strKey$, item1
- Dim arrResult(), arr, arrTemp
- Dim t#
- On Error GoTo ErrorHandler
- t = Timer
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Application.EnableEvents = False
- Application.Calculation = xlCalculationManual
- Columns("a:g").ClearContents
-
- '字典对像
- Set objDic2 = CreateObject("scripting.dictionary")
- Set objDic1 = CreateObject("scripting.dictionary")
- '工作表循环
- For iSheetNumber = 2 To Worksheets.Count
- '读数据
- With Worksheets(iSheetNumber)
- lLastRow = .Cells(Rows.Count, "g").End(xlUp).Row
- arr = .Range("a1:g" & lLastRow).Value
- End With
- '结果数组
- ReDim arrResult(1 To UBound(arr), 1 To UBound(arr, 2))
- '字典对像,可以放在外围,用REMOVE清空即可,
- 'Set objDic2 = CreateObject("scripting.dictionary")
- 'Set objDic1 = CreateObject("scripting.dictionary")
- '字典1装出现资料,字典2装再现时所在的行号
- For i = LBound(arr) + 1 To UBound(arr) Step 3
- strKey = arr(i, 6) & "#" & arr(i, 7)
- objDic1(strKey) = objDic1(strKey) + 1
- objDic2(strKey) = objDic2(strKey) & i & ","
- Next
- For Each item1 In objDic1.keys
- '找出重复的数据,生成结果数组
- If objDic1(item1) >= 2 Then
- arrTemp = Split(objDic2(item1), ",")
- For i = LBound(arrTemp) To UBound(arrTemp) - 1
- lRecord = lRecord + 1
- k = arrTemp(i)
- For j = LBound(arr, 2) To UBound(arr, 2)
- arrResult(lRecord, j) = arr(k - 1, j)
- arrResult(lRecord + 1, j) = arr(k, j)
- Next
- lRecord = lRecord + 2
- Next
- End If
- Next
- With Worksheets(1)
- If lRecord > 0 Then
- lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
- If lLastRow > 1 Then lLastRow = lLastRow + 2
- .Cells(lLastRow, 1).Resize(lRecord, UBound(arrResult, 2)).Value = arrResult
- End If
- End With
- lRecord = 0
- 'Set objDic1 = Nothing
- 'Set objDic2 = Nothing
- objDic1.RemoveAll
- objDic2.RemoveAll
- Erase arr
- Next
- Application.ScreenUpdating = True
- Application.DisplayAlerts = True
- Application.EnableEvents = True
- Application.Calculation = xlCalculationAutomatic
- t = Timer - t
- MsgBox "整理完成" & vbCrLf & "一共用时 " & t & " 秒"
- Exit Sub
- ErrorHandler:
- MsgBox Err.Number & vbCrLf & _
- Err.Description
- Application.ScreenUpdating = True
- Application.DisplayAlerts = True
- Application.EnableEvents = True
- Application.Calculation = xlCalculationAutomatic
- End Sub
复制代码 |
|