数据格式转换

wang-way

JSA 练手

1. function transform3(){
   
2.         var wb=ThisWorkbook;
   
3.         var sht=wb.Worksheets.Item("工艺路线 (整理版)表一");
   
4.         ar=sht.Range('a1').CurrentRegion.Value();
   
5.         //去掉F,G列
   
6.         ar.forEach(r=>{
   
7.                 r.splice(5,2);//第五列 去掉长度2
   
8.         });
   
9.         //列头去掉料号
   
10.         hd=[];
    
11.         hd.push(...ar.slice(0,1)[0].slice(0,1),...ar.slice(0,1)[0].slice(2));
    
12.         //料号去重
    
13.         dic=new Set(ar.slice(1).map(r=>r[1]));
    
14.         //循环料号
    
15.         br=[];
    
16.         var max=0;
    
17.         dic.forEach(k=>{
    
18.                         //筛选数据
    
19.                         ft=ar.slice(1).filter(x=>x[1]==k);
    
20.                         //去除料号
    
21.                         ft.forEach(r=>r.splice(1,1));
    
22.                         if(ft.length+2>max) max=ft.length+2;
    
23.                         //列头
    
24.                         hd.forEach((c,j)=>{
    
25.                                 r=[];
    
26.                                 r.push(k);//添加料号
    
27.                                 r.push(c);//添加列头
    
28.                                 r.push(...ft.map(x=>x[j]));//列转行 展平对应列
    
29.                                 br.push(r);//添加到二维数组
    
30.                         })
    
31.         })
    
32.         sht=wb.Worksheets.Item("模拟的结果");
    
33.         sht.Cells.Clear();
    
34.         //表头 自己修改
    
35.         sht.Range("a1").Value2="xxx计划表";
    
36.         sht.Range("a1").Resize(1,max).Merge();
    
37.         //输出数据
    
38.         sht.Range("a2").Resize(br.length,max).Value2=br;       
    
39.         //合并单元格
    
40.         dic.forEach(k=>{
    
41.                 st=br.map(x=>x[0]).findIndex(x=>x==k)+2;//料号所在的起始行
    
42.                 cnt=br.filter(x=>x[0]==k).length;//每个料号对应的行数 都是5
    
43.                 sht.Cells(st,1).Resize(cnt,1).Merge();//合并料号单元格
    
44.         })
    
45.         //设置格式
    
46.         with (sht.UsedRange){
    
47.       HorizontalAlignment = xlHAlignCenter;//居中
    
48.         Borders.ColorIndex = xlColorIndexAutomatic;//边框
    
49.       Columns.AutoFit()//自动列宽
    
50.     }
    
51. }

复制代码

ww87725244

参与一下

1. Sub aa()
   
2. Dim ar, i, ar1(1 To 1000, 1 To 20), k, m, n, d As Object, s, m1, rng
   
3. Set d = CreateObject("scripting.dictionary")
   
4. s = Array(1, 3, 4, 5, 8)
   
5. With Worksheets("工艺路线 (整理版)表一")
   
6.   ar = .UsedRange
   
7.   For i = 2 To UBound(ar, 1)
   
8.     If Not d.exists(ar(i, 2)) Then
   
9.       k = k + 1
   
10.       m1 = 0
    
11.       ar1(5 * (k - 1) + 1, 1) = ar(i, 2)
    
12.       For m = 0 To UBound(s)
    
13.         ar1(m + 5 * (k - 1) + 1, 2) = ar(1, s(m))
    
14.         ar1(m + 5 * (k - 1) + 1, 3) = ar(i, s(m))
    
15.       Next
    
16.       d(ar(i, 2)) = k
    
17.     Else
    
18.       m1 = m1 + 1
    
19.       n = d(ar(i, 2))
    
20.       For m = 0 To UBound(s)
    
21.         ar1(m + 5 * (n - 1) + 1, m1 + 3) = ar(i, s(m))
    
22.       Next
    
23.     End If
    
24.   Next
    
25. End With
    
26. With Worksheets("模拟的结果")
    
27.   .UsedRange.UnMerge
    
28.   .UsedRange.ClearContents
    
29.   .[a1].Resize(UBound(ar1, 1), UBound(ar1, 2)) = ar1
    
30.   For rng = 1 To .UsedRange.Rows.Count Step 5
    
31.     Range(.Cells(rng, 1), .Cells(rng + 4, 1)).Merge
    
32.   Next
    
33. End With
    
34. End Sub
    

复制代码

yynrzwh

格式转换.zip (36.43 KB, 下载次数: 19)

2024-5-16 22:54 上传

点击文件名下载附件

wqhsz385919

铁马1980 发表于 2024-5-16 20:51
参与一下

结果非常正确，多谢！

wqhsz385919

yynrzwh 发表于 2024-5-16 22:54

谢谢您的帮助，结果非常正确，明天给你补花

wqhsz385919

wang-way 发表于 2024-5-16 22:08
JSA 练手

感谢回复！明天给你补花，非常感谢！

wqhsz385919

cao47112 发表于 2024-5-16 15:41
写的代码也烂（又不是不能用）

我最后是采用您的代码，我还要修改一下，在您的代码上可以随便改，这才是非常好代码！再次感谢！

baofa2

1. Sub test0() '参与，仅参考
   
2.   
   
3.   Dim ar(), br, cr
   
4.   Dim i As Long, j As Long, x As Long, y As Long
   
5.   Dim rowSize As Long, colSize As Long, pos As Long
   
6.   
   
7.   cr = Array(1, 3, 4, 5, 8)
   
8.   With Worksheets("工艺路线 (整理版)表一").Range("A1").CurrentRegion
   
9.     br = .Range(.Cells(1), .Offset(1)).Value
   
10.   End With
    
11.   ReDim ar(1 To UBound(br), 1 To 234)
    
12.   
    
13.   rowSize = 1
    
14.   ar(rowSize, 1) = "工站生产计划"
    
15.   pos = 1
    
16.   For i = 2 To UBound(br) - 1
    
17.     If br(i, 2) <> br(i + 1, 2) Then
    
18.       ar(rowSize + 1, 1) = br(i, 2)
    
19.       For j = LBound(cr) To UBound(cr)
    
20.         x = 2
    
21.         rowSize = rowSize + 1
    
22.         ar(rowSize, x) = br(1, cr(j))
    
23.         For y = pos + 1 To i
    
24.           x = x + 1
    
25.           ar(rowSize, x) = br(y, cr(j))
    
26.         Next
    
27.         If x > colSize Then colSize = x
    
28.       Next
    
29.       pos = i
    
30.     End If
    
31.   Next
    
32.   
    
33.   With Worksheets("自动转换").Range("A1")
    
34.     .CurrentRegion.Clear
    
35.     With .Resize(rowSize, colSize)
    
36.       .Borders.LineStyle = xlContinuous
    
37.       .HorizontalAlignment = xlCenter
    
38.       .Value = ar
    
39.     End With
    
40.     .Resize(, colSize).HorizontalAlignment = xlCenterAcrossSelection
    
41.     i = 0
    
42.     For y = rowSize To 2 Step -1
    
43.       i = i + 1
    
44.       If Len(ar(y, 1)) Then
    
45.         .Offset(y - 1).Resize(i).Merge
    
46.         i = 0
    
47.       End If
    
48.     Next
    
49.   End With
    
50.   
    
51.   Beep
    
52. End Sub
    

复制代码

cao47112

wqhsz385919 发表于 2024-5-18 07:57
我最后是采用您的代码，我还要修改一下，在您的代码上可以随便改，这才是非常好代码！再次感谢！

哈哈哈感谢这特殊的认可，改好了可以再发上来互相学习一下哦

wqhsz385919

cao47112 发表于 2024-5-20 09:58
哈哈哈感谢这特殊的认可，改好了可以再发上来互相学习一下哦

我只改了一下要填入到单元格的范围，总体就是您的代码，就不发了，谢谢！