|
本帖最后由 hasyh2008 于 2022-5-19 09:43 编辑
Sub 提取数据()
On Error Resume Next
Dim Arr(), Brr
Dim Rc%, Cl%, X%, Y%, I%, Dic, K, It
Set Dic = CreateObject("scripting.dictionary")
Arr = Sheet2.Range("A1").CurrentRegion
Rc = UBound(Arr)
Cl = UBound(Arr, 2)
Sheet3.UsedRange.ClearContents
For X = 1 To Rc
Dic.RemoveAll
For Y = 1 To Cl
Brr = Split(Arr(X, Y), " ")
For I = 0 To UBound(Brr)
Dic(Brr(I)) = Dic(Brr(I)) + 1
Next I
K = Dic.keys
It = Dic.items
Next Y
With Sheet3
If .Cells(1, 1) = "" Then
.Cells(1, 1).Resize(UBound(K) + 1) = Application.Transpose(K)
Else
.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Resize(UBound(K) + 1) = Application.Transpose(K)
End If
.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Resize(UBound(It) + 1) = Application.Transpose(It)
End With
Next X
Set Dic = Nothing
End Sub |
|