感觉较复杂的排列文字，请老师出手

longming3 · 发表于 2024-10-9 13:33

这样的数据，转换成下图的文字

不知老师有没有很好的方法，先谢谢

likaiyihou · 发表于 2024-10-9 14:00

代码如下：

likaiyihou · 发表于 2024-10-9 14:04

刚发现有一个小问题，二级标题（“1、期初”，“2、资金投入”....）前面忘了设置空格，请自己修改代码（变量str_xm赋值在前面加空格）。

ykcbf1100 · 发表于 2024-10-9 14:25

本帖最后由 ykcbf1100 于 2024-10-9 14:52 编辑

看着简单，其实也麻烦的。
改用一个字典。。。

ykcbf1100 · 发表于 2024-10-9 14:26

本帖最后由 ykcbf1100 于 2024-10-9 14:34 编辑

参与一下。

小凡、、、 · 发表于 2024-10-9 14:28

本帖最后由小凡、、、于 2024-10-9 14:36 编辑

很相似了，小数位数要修改的话再改改格式

飞天篮球猪 · 发表于 2024-10-9 14:54

供参考...

titi012 · 发表于 2024-10-9 14:59

参与一下。。。。。

Sub test()
Dim d As Object, d1 As Object, Arr, i&, j&, n&, m, x&, k, s
Arr = Range("c6:e" & Cells(9999, 5).End(xlUp).Row)
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Arr)
If Not d.exists(Arr(i, 2)) Then Set d(Arr(i, 2)) = CreateObject("Scripting.Dictionary")
d(Arr(i, 2))(Arr(i, 3)) = Arr(i, 1) + d(Arr(i, 2))(Arr(i, 3))
d1(Arr(i, 2)) = Arr(i, 1) + d1(Arr(i, 2))
m = Arr(i, 1) + m
Next i
ReDim Arr(0 To UBound(Arr) * 2, 1 To 1)
Arr(0, 1) = "收入合计：" & Round(m, 0) / 10000 & "万元"
For Each k In d.keys
x = x + 1: n = n + 1
Arr(x, 1) = " " & n & "、" & k & " " & Round(d1(k), 0) / 10000 & "万元"
For Each s In d(k).keys
x = x + 1
Arr(x, 1) = " -" & s & " " & Round(d(k)(s), 0) / 10000 & "万元"
Next
Next
Range("G6").Resize(x + 1, 1) = Arr
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

[求助] 感觉较复杂的排列文字，请老师出手