跪求代码

gbscd

VBA票求:
右边的数据源，按照左边这样的格式和内容填充，烦请高手留步

shiruiqiang

============

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.2.2
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     r = Me.Cells(Rows.Count, "r").End(3).Row
   
5.     arr = Me.Range("q1:ad" & r)
   
6.     ReDim brr(1 To 10000, 1 To 100)
   
7.     For i = 3 To UBound(arr)
   
8.         For j = 5 To 12
   
9.             If arr(i, j) <> Empty Then
   
10.                 m = m + 1
    
11.                 brr(m, 1) = arr(i, 1)
    
12.                 brr(m, 2) = arr(i, 4)
    
13.                 brr(m, 3) = Format(arr(i, 3), "yyyy年m月d日")
    
14.                 brr(m, 4) = arr(2, j)
    
15.                 brr(m, 9) = arr(i, j)
    
16.                 brr(m, 11) = arr(i, 14)
    
17.             End If
    
18.         Next
    
19.     Next
    
20.     Me.Range("a3:o1000").UnMerge
    
21.     Me.Range("a3:o1000") = ""
    
22.     With Me.Range("a3").Resize(m, 15)
    
23.         .Value = brr
    
24.         .Borders.LineStyle = 1
    
25.         .HorizontalAlignment = xlCenter
    
26.         .VerticalAlignment = xlCenter
    
27.     End With
    
28.     r = Me.Cells(Rows.Count, 1).End(3).Row
    
29.     Dim rng As Range
    
30.     c = 11     '//合并单元格列号
    
31.     For i = r To 3 Step -1
    
32.         Set rng = Me.Cells(i, c)
    
33.         Set Rng1 = rng.Offset(-1)
    
34.         If rng = Rng1 Then
    
35.             Me.Cells(i, c).Offset(-1).Resize(2).Merge
    
36.         End If
    
37.         
    
38.     Next
    
39.     Application.ScreenUpdating = True
    
40.     MsgBox "OK！"
    
41. End Sub
    
42. 
    

复制代码

gbscd

shiruiqiang 发表于 2024-2-2 17:44
============

谢谢老师，真心感谢！

gbscd

ykcbf1100 发表于 2024-2-2 19:31
附件供参考。。。

谢谢老师，真心感谢您的帮助，谢谢！

gbscd

ykcbf1100 发表于 2024-2-2 19:31
参与一下。。。

谢谢老师，真心感谢您的帮助，真心谢谢！