Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 908|回复: 3

求助个数

[复制链接]
发表于 2022-5-19 01:27 | 显示全部楼层 |阅读模式
本帖最后由 1小小草 于 2022-5-19 01:32 编辑

求助个数

新建 Office Excel 工作表 - 副本 (1).zip

10.78 KB, 下载次数: 18

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2022-5-19 08:29 | 显示全部楼层
本帖最后由 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

字典法提取字符出现次数(20220519).rar

22.54 KB, 下载次数: 1

回复

使用道具 举报

发表于 2022-5-19 10:46 | 显示全部楼层
新建 Microsoft Office Excel 工作表 - 副本.zip (19.59 KB, 下载次数: 13)
回复

使用道具 举报

 楼主| 发表于 2022-5-26 18:35 | 显示全部楼层
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 23:15 , Processed in 0.403478 second(s), 11 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表