分行分列，提取不了数据，谢谢四位老师！

lhj323323 · 发表于 2024-1-26 09:02

本帖最后由 lhj323323 于 2024-1-26 22:26 编辑

老师：

上传的附件里有写好的语句

但仅能实现一部分功能，请看下图
快照5.png

求助.rar (30.82 KB, 下载次数: 15)
老师如有空，请帮忙看看，先谢谢了！

ykcbf1100 · 发表于 2024-1-26 10:04

这个今年是指的哪一年？2024？还是2023？

liulang0808 · 发表于 2024-1-26 10:15

Option Explicit
Sub test()
Dim Arr, brr, d As Object, d1 As Object
Dim k
Dim i%, j%, m%, n%
Dim s$, ss$

Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
With Sheet1
   Arr = .[a1].CurrentRegion

ReDim brr(1 To UBound(Arr), 1 To 1000)
For i = 2 To UBound(Arr) '
   'If InStr(Arr(i, 3), "STR") > 0 Then'--------------这一句，不知该添加到哪里
         s = Left(Arr(i, 1), 4): ss = Arr(i, 2)
         '结果表横向标题，纵向标题


      If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
      d(s)(ss) = Arr(i, 4)
      d1(ss) = ""
Next

ReDim brr(1 To UBound(Arr), 1 To 5000)
m = 1: n = 1
brr(1, 1) = "金额"
For Each k In d.Keys
      n = n + 1
      brr(1, n) = k
Next
For Each k In d1.Keys
      m = m + 1
      brr(m, 1) = k
Next
On Error Resume Next

'导入到结果表区域
.[l1].Resize(m, n) = brr

Arr = .[l1].Resize(m, n)
For j = 2 To UBound(Arr, 2)
      For i = 2 To UBound(Arr)
         s = Left(Arr(1, j), 4): ss = Arr(i, 1)
         Arr(i, j) = d(s)(ss)
      Next
Next

.[l1].Resize(m, n) = Arr
End With

End Sub

liulang0808 · 发表于 2024-1-26 10:16

求助.zip (36 KB, 下载次数: 8)
新增加那三列，不知道什么逻辑
之前不输出结果部分，做了需改

ykcbf1100 · 发表于 2024-1-26 10:38

本帖最后由 ykcbf1100 于 2024-1-28 11:38 编辑

参与一下，代码以附件为立准。

Sub ykcbf() '//2024.1.26
Dim arr, brr, d
Set d = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set d3 = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
r = Me.Cells(Rows.Count, 1).End(3).Row
Me.Range("a2:d" & r - 1).Sort Me.[a2], 1
arr = Me.Range("a1:d" & r)
jn = Year(Date)
For i = 2 To UBound(arr)
If arr(i, 3) = "STR" Then
s = Left(CStr(arr(i, 1)), 4)
d2(s) = ""
s = arr(i, 2)
p1 = IIf(Left(CStr(arr(i, 1)), 4) = CStr(jn), arr(i, 4), 0)
p2 = p2 + IIf(Left(CStr(arr(i, 1)), 4) = CStr(jn), arr(i, 4), 0)
p3 = p3 + arr(i, 4)
If Not d.exists(s) Then
d3(s) = Array(s, p1, p2, p3)
Else
t = d3(s)
t(1) = t(1) + p1
t(2) = t(2) + p2
t(3) = t(3) + p3
d3(s) = t
End If
s = arr(i, 2) & "|" & Left(CStr(arr(i, 1)), 4)
d(s) = d(s) + arr(i, 4)
End If
Next
Me.[l2:z10000] = ""
Me.[p1:z1] = ""
Me.[p1].Resize(1, d2.Count) = d2.keys
Me.[l2].Resize(d3.Count, 4) = Application.Rept(d3.Items, 1)
arr = Me.[l1].Resize(d3.Count + 1, d2.Count + 4)
For i = 2 To UBound(arr)
For j = 5 To UBound(arr, 2)
s = arr(i, 1) & "|" & arr(1, j)
If d.exists(s) Then
arr(i, j) = d(s)
End If
Next
Next
Me.[l1].Resize(d3.Count + 1, d2.Count + 4) = arr
Set d = Nothing
Set d2 = Nothing
Set d3 = Nothing
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

ykcbf1100 · 发表于 2024-1-26 10:39

假定表中的今年是2024年

附件供参考。。。

lhj323323 · 发表于 2024-1-26 11:18

ykcbf1100 发表于 2024-1-26 10:04
这个今年是指的哪一年？2024？还是2023？

今年是个动态的概念，即是数值最大的一年，比如数据源里最大的一年是1998，则，今年就是1998

ykcbf1100 · 发表于 2024-1-26 11:25

lhj323323 发表于 2024-1-26 11:18
今年是个动态的概念，即是数值最大的一年，比如数据源里最大的一年是1998，则，今年就是1998

那改一下吧。

yynrzwh · 发表于 2024-1-26 11:31

猜的

求助2.rar (31.16 KB, 下载次数: 5)

cidanji · 发表于 2024-1-26 11:37

我觉得有个歧义的地方，后面绿色的每年统计，是仅STR还是所有标识

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

[已解决] 分行分列，提取不了数据，谢谢四位老师！

评分

评分

评分

评分