|
发表于 2013-5-1 10:03
|
显示全部楼层
本楼为最佳答案
- Sub test()
- Dim lCol&
- Dim lRept&
- Dim result, arr
- Dim lLastRow&
- 'Columns(1).ClearContents
- 'lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
- Application.ScreenUpdating = False
- For lCol = 9 To 12
- If VBA.IsNumeric(Cells(1, lCol)) And Len(Cells(1, lCol)) > 0 Then
- If Cells(1, lCol) < 9 Or Cells(1, lCol) > 32 Then
- arr = Range(Cells(3, lCol), Cells(10000, lCol))
- result = CheckRept(arr, Cells(1, lCol))
- If IsArray(result) Then
- lLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
- Cells(lLastRow, 1).Resize(UBound(result)) = WorksheetFunction.Transpose(result)
- 'lLastRow = lLastRow + UBound(result)
- End If
- End If
- End If
- Next
- Application.ScreenUpdating = True
- MsgBox "提取完成"
- End Sub
- Function CheckRept(arr, lCondition As Long)
- If Not IsArray(arr) Then CheckRept = False: Exit Function
- If lCondition <= 0 Then CheckRept = False: Exit Function
- Dim lCount&
- Dim result()
- Dim dic As Object
- Set dic = CreateObject("scripting.dictionary")
- Dim i As Long
- Dim keys
- ReDim result(1 To 1)
- For i = LBound(arr) To UBound(arr)
- dic(arr(i, 1)) = dic(arr(i, 1)) + 1
- Next
- For Each keys In dic.keys
- If dic(keys) = lCondition Then
- lCount = lCount + 1
- ReDim Preserve result(1 To lCount)
- result(lCount) = "'" & keys
- End If
- Next
- If lCount > 1 Then
- CheckRept = result
- Else
- CheckRept = False
- End If
- End Function
复制代码 |
|