vba 汇总然后变成横向排列

沈默00

有些不是数值格式的没有参与计算

沈默00

结果放在表2，

3190496160

Sub 汇总()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ar As Variant
Dim d As Object
Dim br()
Set d = CreateObject("scripting.dictionary")
With Sheets("sheet0")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    y = .Cells(1, Columns.Count).End(xlToLeft).Column
    If r < 2 Or y < 3 Then MsgBox "数据表为空！": End
    ar = .Range(.Cells(1, 1), .Cells(r, y))
End With
ReDim br(1 To UBound(ar), 1 To 1000)
br(1, 1) = "车牌号"
y = 1: k = 2
For i = 2 To UBound(ar)
    If ar(i, 1) <> "" Then
        t = d(ar(i, 1))
        If t = "" Then
            k = k + 1
            d(ar(i, 1)) = k
            t = k
            br(k, 1) = ar(i, 1)
        End If
        For j = 3 To UBound(ar, 2)
            zd = ar(i, 2) & "|" & ar(1, j)
            lh = d(zd)
            If lh = "" Then
                y = y + 1
                d(zd) = y
                lh = y
                br(1, y) = ar(i, 2)
                br(2, y) = ar(1, j)
            End If
            br(t, lh) = br(t, lh) + Val(ar(i, j))
        Next j
    End If
Next i
With Sheets("汇总")
    .[a1].CurrentRegion.Clear
    .[a1].Resize(k, y) = br
    .[a1].Resize(k, y).Borders.LineStyle = 1
    ls = UBound(ar, 2) - 2
    For j = 2 To y Step ls
        .Cells(1, j).Resize(1, ls).Merge
    Next j
    .Rows("1:1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

20231228-122639.rar (18.52 KB, 下载次数: 42)

2023-12-28 14:55 上传

点击文件名下载附件

LIUZHU

JSA版本

1. function 转换(){
   
2.         let arr=Range("a1").CurrentRegion.Value2;
   
3.         let obj={"bt":[,],"cp":[,],"gzl":[,]},bt=arr[0];
   
4.         arr.slice(1).forEach(x=>{
   
5.                 let temp=obj[x[0]]=obj[x[0]] || [x[0]];
   
6.                 bt.forEach((y,i)=>{
   
7.                         if (i<=1) return;
   
8.                         let key=x[1] + y;
   
9.                         if (!obj["bt"].includes(key)){
   
10.                                 obj["bt"].push(key),obj["gzl"].push(y);
    
11.                                 !obj["cp"].includes(x[1])?obj["cp"][obj["bt"].length-1]=x[1]:null;
    
12.                         }
    
13.                         let n=obj["bt"].indexOf(key);
    
14.                         temp[n]=temp[n]==null?x[i]:temp[n]+x[i];
    
15.                 });
    
16.         });
    
17.         let res=Object.values(obj).slice(1);
    
18.         Range("h1").CurrentRegion.EntireColumn.Delete();
    
19.         Range("h1").Resize(res.length,res[1].length).Value2=res;
    
20.         let c=Cells.Item(2,Columns.Count).End(xlToLeft).Column;
    
21.         for (let i=c;i>=Range("h1").Column;i--){
    
22.                 if (Cells.Item(1,i).Value2!=null) Cells.Item(1,i).Resize(1,bt.length-2).Merge();
    
23.         }
    
24.         Range("h1").CurrentRegion.HorizontalAlignment=xlHAlignCenter;
    
25. }

复制代码

LIUZHU

附件，WSP测试

jjmysjg

沈默00 发表于 2023-12-28 13:39

选定区域包含多重数值，合并到一个单元格只能保留最左上角的数据。
需要不断的点确定。
怎么在代码中解决？
谢谢

戎马书生222

jjmysjg 发表于 2024-7-18 09:51
选定区域包含多重数值，合并到一个单元格只能保留最左上角的数据。
需要不断的点确定。
怎么在代码中解 ...

加上 On Error Resume Next

jjmysjg

戎马书生222 发表于 2024-7-18 16:31
加上 On Error Resume Next

没有效果，继续提示合并

戎马书生222

jjmysjg 发表于 2024-7-18 19:05
没有效果，继续提示合并

还有一个application.DisplayAlerts =False