帮忙写VBA代码，跪求大佬

故人、

请大佬帮忙，我想好久也没有好的方法和思路，数据源和表格都在附件了，谢谢~~~~~
源格式


目标格式

故人、

我顶顶顶顶顶

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.1.30
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     With Sheets("原数据")
   
4.         r = .Cells(Rows.Count, 1).End(3).Row
   
5.         arr = .Range("a1:AA" & r)
   
6.     End With
   
7.     For i = 2 To UBound(arr)
   
8.         For j = 2 To UBound(arr, 2)
   
9.             s = arr(i, 1) & "|" & arr(1, j)
   
10.             d(s) = arr(i, j)
    
11.         Next
    
12.     Next
    
13.     With Sheets("想变更成的格式")
    
14.         r = .Cells(Rows.Count, 2).End(3).Row
    
15.         arr = .Range("a1:o" & r)
    
16.         For i = 2 To UBound(arr)
    
17.             If arr(i, 1) <> Empty And arr(i, 1) <> "名称" Then
    
18.                 For j = 3 To UBound(arr, 2)
    
19.                     s = arr(i, 1) & "|" & arr(i - 1, j)
    
20.                     arr(i, j) = d(s)
    
21.                 Next
    
22.             End If
    
23.         Next
    
24.         .Range("a1:o" & r) = arr
    
25.     End With
    
26.     Set d = Nothing
    
27.     MsgBox "OK！"
    
28. End Sub

复制代码

ykcbf1100

附件供参考。。。

故人、

ykcbf1100 发表于 2024-1-30 21:51
附件供参考。。。

大佬哇，是新建一个表贴进去

mafect

我只是来学习的

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, i&, Rng As Range, iPosRow&
   
    Application.ScreenUpdating = False
   
    With [A1].CurrentRegion
        With Intersect(.Offset(), .Offset(1))
            ar = .Value
            ReDim br(1 To UBound(ar), 2)
            For i = 1 To UBound(ar)
                br(i, 0) = ar(i, 1)
                br(i, 1) = .Cells(i, 2).Resize(, 13).Value
                br(i, 2) = .Cells(i, 15).Resize(, 13).Value
            Next i
        End With
    End With
   
    Set Rng = [AD1:AR13]
    With Workbooks.Add
        For i = 1 To UBound(br)
            iPosRow = (i - 1) * 14 + 1
            With .Worksheets(1)
                rngCopyToSame Rng, .Cells(iPosRow, 1)
                With .Cells(iPosRow, 1)
                    .Cells(2, 1).Value = br(i, 1): .Cells(2, 4).Value = br(i, 0)
                    .Cells(2, 3).Resize(, 13) = br(i, 1)
                    .Cells(4, 3).Resize(, 13) = br(i, 2)
                End With
            End With
        Next i
    End With
    Application.ScreenUpdating = True
    Beep
End Sub
Function rngCopyToSame(ByVal rngSel As Range, ByVal rngTarget As Range)
    Dim i&
    rngSel.Copy
    rngTarget.PasteSpecial xlPasteColumnWidths
    rngSel.Copy rngTarget
    With rngTarget.Resize(rngSel.Rows.Count, rngSel.Columns.Count)
        For i = 1 To .Rows.Count
            .Rows(i).RowHeight = rngSel.Rows(i).RowHeight
        Next i
    End With
End Function

gwjkkkkk

请参考附件。。。