求大神用vba写一段代码

Question

求大神用vba写一段代码
数据a sheet1 A列 数据如下
PSVO
PSVO38
SVO26
IO
ENC
IO
PSVO
要求对这列数据进行统计计数，将结果显示在数据B sheet1 A B 列
最终结果
A B
PSVO 2
PSVO38 1
SVO26 1
IO 2
ENC 1

Answer 1

工作簿的名字没给不好弄，现就将结果放在C、D列。

Sub demo()
    Dim d As Object, i As Long
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        If Not d.exists(Cells(i, 1).Value) Then
            d(Cells(i, 1).Value) = 1
        Else
            d(Cells(i, 1).Value) = d(Cells(i, 1).Value) + 1
        End If
    Next
    Range("C2").Resize(d.Count, 1) = Application.Transpose(Filter(d.keys, ""))
    Range("D2").Resize(d.Count, 1) = Application.Transpose(Filter(d.items, ""))
End Sub

追问

数据A和数据B就是工作蒲名字

追答

Sub demo()
Dim d As Object, i As Long
Set d = CreateObject("scripting.dictionary")
With Workbooks("数据a.xlsm").Sheets("Sheet1")
For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
If Not d.exists(.Cells(i, 1).Value) Then
d(.Cells(i, 1).Value) = 1
Else

d(.Cells(i, 1).Value) = d(.Cells(i, 1).Value) + 1
End If
Next
End With
With Workbooks("数据B.xlsx").Sheets("Sheet1")
.Range("A2").Resize(d.Count, 1) = Application.Transpose(Filter(d.keys, ""))
.Range("B2").Resize(d.Count, 1) = Application.Transpose(Filter(d.items, ""))
End With
End Sub

Answer 2

你这里数据a，数据b 是两个工作簿文件？追问

是的

追答Dim MyRows1 As Integer
Dim ThisValue As String
Dim MyDataText() As String
Dim MyDataNumb() As Integer
Dim n As Integer
Dim i As Integer

MyRows1 = 1
n = 0

Do While Workbooks("数据a.xlsx").Sheets("Sheet1").Cells(MyRows1, 1).Value <> ""
   ThisValue = Workbooks("数据a.xlsx").Sheets("Sheet1").Cells(MyRows1, 1).Value
   
   For i = 1 To n
      If MyDataText(i) = ThisValue Then
         MyDataNumb(i) = MyDataNumb(i) + 1
         Exit For
      End If
   Next i
   If i > n Then
      n = n + 1
      ReDim Preserve MyDataText(n) As String
      MyDataText(n) = ThisValue
      ReDim Preserve MyDataNumb(n) As Integer
      MyDataNumb(n) = 1
   End If
   
   MyRows1 = MyRows1 + 1
Loop
   
For i = 1 To n
   Workbooks("数据b.xlsx").Sheets("Sheet1").Cells(i, 1) = MyDataText(i)
   Workbooks("数据b.xlsx").Sheets("Sheet1").Cells(i, 2) = MyDataNumb(i)
Next i

Answer 3

Sub 宏1()
    Dim arr, o, i, x
    Set o = CreateObject("Scripting.Dictionary")
    arr = Sheets("Sheet1").UsedRange
    For i=1 To UBound(arr)
        x = arr(i,1)
        o(x) = o(x) + 1
    Next i
    ReDim arr(i, 2)
    i = 1
    For Each x In o.Keys
        arr(i,1) = x
        arr(i,2) = o(x)
        i = i + 1
    Next x
    i = i - 1
    Sheets("Sheet2").Range("A1").ReSize(i, 2) = arr
End Sub

追问

可以加个联系方式么，我还有一个程序需要写

Answer 4

可以以人民币结算么追问

什么

追答

快自己好好做作业吧，不明白翻翻书！