将单元格内文字提取作为表头并对应金额

zzq0117

将单元格内文字提取作为表头并对应金额

fzxba

Sub test1()
  
  仓促，不合题意，见更改附件
  
End Sub

fzxba

改一下.zip (21.38 KB, 下载次数: 13)

2024-3-12 15:25 上传

点击文件名下载附件

zzq0117

fzxba 发表于 2024-3-12 15:05

老师，这个文字的表头没出来。

fzxba

zzq0117 发表于 2024-3-12 15:10
老师，这个文字的表头没出来。

明白了，没搞清楚，不好意思再来，楼下老师继续……

补，还是改一下吧：

Sub test1()
  
  Dim result()
  Dim ar, br, cr, Dict As Object
  Dim i As Long, j As Long, k As Long, p As Long
  
  Set Dict = CreateObject("Scripting.Dictionary")
  ar = Range("Q1", Range("Q1").End(xlDown))
  ReDim result(1 To UBound(ar), 1 To 80)
  For i = 2 To UBound(ar)
    br = Split(Trim(ar(i, 1)), ";")
    For j = 0 To UBound(br)
      If Len(br(j)) Then
        cr = Split(br(j), ":")
        If Not Dict.Exists(cr(0)) Then
          k = k + 1
          Dict.Add cr(0), k
          result(1, k) = cr(0)
        End If
        result(i, Dict(cr(0))) = Val(cr(UBound(cr)))
      End If
    Next
  Next
  
  Range("R1").Resize(UBound(result), k) = result
  
  Set Dict = Nothing
  Beep
End Sub

cnmlgb9998

用PQ 不香？？？？？？？？？？？？？？？？？？？？

这个年纪118

新手练习！！！！！！！！！！

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.3.12
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     r = Cells(Rows.Count, 1).End(3).Row
   
5.     arr = [a1].Resize(r, 17)
   
6.     For i = 2 To UBound(arr)
   
7.         b = Split(Trim(arr(i, 17)), ";")
   
8.         For x = 0 To UBound(b)
   
9.             If b(x) <> Empty Then
   
10.                 bb = Split(b(x), ":")
    
11.                 s = bb(0)
    
12.                 If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
13.                 d(s)(i) = Val(bb(1))
    
14.             End If
    
15.         Next
    
16.     Next
    
17.     [r1].Resize(r, 20) = ""
    
18.     [r1].Resize(1, d.Count) = d.keys
    
19.     arr = [a1].Resize(r, 17 + d.Count)
    
20.     For j = 18 To UBound(arr, 2)
    
21.         s = arr(1, j)
    
22.         If d.exists(s) Then
    
23.             For i = 2 To UBound(arr)
    
24.                 arr(i, j) = d(s)(i)
    
25.             Next
    
26.         End If
    
27.     Next
    
28.     [a1].Resize(r, 17 + d.Count) = arr
    
29.     Set d = Nothing
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "OK！"
    
32. End Sub
    
33. 
    

复制代码

zzq0117

fzxba 发表于 2024-3-12 15:05

这下好了，非常谢谢老师。