以科目为关键字横向写入各年度数据

jjmysjg · 发表于 2024-4-16 15:26

提取各表B列科目代码不重复值到汇总表B列，提取各表字段中的“借方合计”、“贷方合计”列的字段到本表1、2行横向，对应数据填充到本表。
各年度科目代码不一样。
本表是用数值VLOOKUP实现的，公式不能横向复制，工作量大。
谢谢各位大师！

ykcbf1100 · 发表于 2024-4-16 16:05

本帖最后由 ykcbf1100 于 2024-4-17 09:37 编辑

全表自动生成，附件供参考。。。

蓝桥玄霜 · 发表于 2024-4-16 16:11

汇总的例子：

ykcbf1100 · 发表于 2024-4-16 16:13

本帖最后由 ykcbf1100 于 2024-4-17 09:36 编辑

参与一下。。。

Sub ykcbf() '//2024.4.17
Dim arr, brr, d, s
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
Set sh = ThisWorkbook.Sheets("汇总")
ReDim brr(1 To 10000, 1 To 300)
m = 2: n = 3: bt = 2
On Error Resume Next
For Each Sht In Sheets
If Sht.Name <> sh.Name Then
k = k + 1
With Sht
r = .Cells(Rows.Count, 1).End(3).Row
c = .UsedRange.Columns.Count
arr = .Range("a1").Resize(r, c)
If k = 1 Then
brr(1, 1) = arr(2, 1): brr(1, 2) = arr(2, 2): brr(1, 3) = arr(2, 3)
End If
For i = bt + 1 To UBound(arr)
If arr(i, 1) <> Empty Then
s = CStr(arr(i, 2))
If Not d.exists(s) Then
m = m + 1
d(s) = m
brr(m, 1) = m - 2
brr(m, 2) = s
brr(m, 3) = arr(i, 3)
End If
r = d(arr(i, 2))
For j = 4 To UBound(arr, 2) Step 6
For x = 1 To 2
s = arr(1, j) & "|" & arr(2, j + x)
If Not d.exists(s) Then
n = n + 1
d(s) = n
brr(1, n) = Format(arr(1, j), "yyyy年m月")
brr(2, n) = arr(2, j + x)
End If
c = d(arr(1, j) & "|" & arr(2, j + x))
brr(r, c) = arr(i, j + x)
Next
Next
End If
Next
End With
End If
Next
With sh
.UsedRange.Clear
.Columns(2).NumberFormatLocal = "@"
.[a1].Resize(m, n - 1) = brr
.[a1].Resize(2, n - 1).Interior.Color = 49407
.[a3].Resize(m - 2, 1).Interior.Color = 5296274
For j = 1 To 3
.Cells(1, j).Resize(2).Merge
Next
For j = 4 To n Step 2
.Cells(1, j).Resize(1, 2).Merge
Next
ActiveWindow.DisplayZeros = False
Set Rng = .[a1].Resize(m, n - 1)
With Rng
.Borders.LineStyle = 1
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Columns.AutoFit
With .Font
.Name = "微软雅黑"
.Size = 11
End With
End With
End With
Set d = Nothing
MsgBox "OK！"
End Sub

复制代码

LIUZHU · 发表于 2024-4-16 17:12

JSA代码参与下

function 汇总(){
let obj={"a01":["序号","科目代码","科目名称"],"a02":[,,,]};
let k=0;
[...Sheets].forEach(sh=>{
if (!/\d{4}/.test(sh.Name)) return;
let arr=sh.Range("a1").CurrentRegion.Value2;
let bt1=arr[0],bt2=arr[1];
arr.slice(2).forEach(x=>{
let temp=obj[`a${x[1]}`]=obj[`a${x[1]}`] || [++k,x[1],null];
let n;
for (let i=3;i<x.length;i++){
if (bt1[i]!=null){
if (obj["a01"].indexOf(bt1[i])==-1){
obj["a01"].push(bt1[i],null),obj["a02"].push("借方合计","贷方合计");
}
n=obj["a01"].indexOf(bt1[i]);
}
if (bt2[i]=="借方合计"){
temp[n]=x[i]==null?temp[n]:((temp[n] || 0) + (x[i] || 0));
}else if(bt2[i]=="贷方合计"){
temp[n+1]=x[i]==null?temp[n+1]:((temp[n+1] || 0) + (x[i] || 0));
}
}
});
});
let res=Object.values(obj);
Sheets.Item("汇总").Activate();
Cells.ClearContents();
Range("a1").Resize(res.length,res[0].length).Value2=res;
res[0].forEach((x,i)=>{
if (typeof x=="string"){
Cells.Item(1,i+1).Resize(2,1).Merge();
}else if(typeof x=="number"){
Cells.Item(1,i+1).Resize(1,2).Merge();
}
});
Range("a1").CurrentRegion.Borders.LineStyle=1;
}

复制代码

LIUZHU · 发表于 2024-4-16 17:13

也是一键汇总，WPS打开测试

jjmysjg · 发表于 2024-4-16 19:53

ykcbf1100 发表于 2024-4-16 16:05
全表自动生成，附件供参考。。。

这个居然能自动生成，真是没有想到能做到！！

ykcbf1100 · 发表于 2024-4-16 20:03

jjmysjg 发表于 2024-4-16 19:53
这个居然能自动生成，真是没有想到能做到！！

这个汇总表全自动生成是比较合理的，因为你的年度数据会增加或减少。

ooluckydog · 发表于 2024-4-16 22:09

参与一下

yynrzwh · 发表于 2024-4-16 23:32

以科目为关键字横向写入各年度数据.zip (177.71 KB, 下载次数: 27)

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

[求助] 以科目为关键字横向写入各年度数据

评分

评分

评分

评分

最新热点 /1