把明细数据按照模版拆分到同一个工作表的难题

zhangstone

各位VBA高手：

     我是一个VBA大白，想把明细数据按照模版拆分到同一个工作表，要求如下：
1、我想把明细表中的数据，按照模版的样式一一填充好后，依次向下排好
2、每个模版之间的间隔1行
3、表头序号依次填充
恳请高手相助！

心的启点

你这个有点麻烦啊

chxw68

详见附件。

zhangstone

chxw68：
你就是大神！超级感谢

chxw68

完善了两点：一是每个表格中间加了分页符；二是根据模板表设置了结果表中的行高。

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br(), cr, i&, j&, k&, n&, r&, Rng As Range
   
    Application.ScreenUpdating = False
   
    With Worksheets("明细").[A1].CurrentRegion
        ar = .Value
        For i = 2 To UBound(ar)
            If Len(ar(i, 1)) Then
                r = r + 1
                ReDim Preserve br(1 To 2, 1 To r)
                br(1, r) = i
            End If
        Next i
        For j = 1 To UBound(br, 2)
            If j = UBound(br, 2) Then
                br(2, j) = .Cells(br(1, j), 1).Resize(UBound(ar) - br(1, j) + 1).Resize(, UBound(ar, 2))
            Else
                br(2, j) = .Cells(br(1, j), 1).Resize(br(1, j + 1) - br(1, j)).Resize(, UBound(ar, 2))
            End If
        Next j
        
        ar = Array(1, 2, 3, 7, 9, 10, 11)
        For k = 1 To UBound(br, 2)
            ReDim cr(1 To 5, 1 To 11)
            For i = 1 To UBound(br(2, k))
                For j = 0 To UBound(ar)
                    cr(i, ar(j)) = br(2, k)(i, j + 16)
                Next j
            Next i
            br(1, k) = cr
        Next k
    End With
   
    Set Rng = Worksheets("模板").[A1:L12]
    ar = [{"B2","D2","F2","H2","J2","L2","B3","E3","H3","J3","L3","C4","E4","I4","K4"}]
    With Worksheets("样例")
        .Cells.Delete
        For i = 1 To UBound(br, 2)
            n = (i - 1) * 13 + 1
            With .Cells(n, 1)
                rngCopyToSame Rng, .Range("A1")
                .Range("A1") = "失业人员就业帮扶记录（" & i & "）号"
                For j = 1 To UBound(ar)
                    .Range(ar(j)).Value = br(2, i)(1, j)
                Next j
                .Range("A8").Resize(UBound(br(1, i)), UBound(br(1, i), 2)) = br(1, i)
            End With
        Next i
        .Activate
    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

请参考附件。。。

Qs18

1. Sub qs()
   
2. Dim arr, i, dic, r
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. arr = Sheet3.Range("a2:v" & Sheet3.Cells(Rows.Count, "v").End(xlUp).Row)
   
5. a = [{"B2","D2","F2","H2","J2","L2","B3","E3","H3","J3","L3","G4","E4","I4","K4"}]
   
6. b = [{1,2,3,7,9,10,12}]
   
7. For i = 1 To UBound(arr)
   
8.     If arr(i, 1) = "" Then
   
9.         For j = 1 To 15
   
10.             arr(i, j) = arr(i - 1, j)
    
11.         Next
    
12.      End If
    
13.    If Not dic.exists(arr(i, 1)) Then
    
14.     dic(arr(i, 1)) = i
    
15.    Else
    
16.     dic(arr(i, 1)) = dic(arr(i, 1)) & "|" & i
    
17.    End If
    
18. Next
    
19. With Sheet2
    
20.     For Each k In dic.keys
    
21.          xx = Split(dic(k), "|")
    
22.         m = m + 1
    
23.         .Range("a1").Value = "失业人员就业帮扶记录（" & m & "）号"
    
24.         For j = 1 To 15
    
25.             .Range(a(j)) = ""
    
26.             .Range(a(j)) = arr(Val(xx(0)), j)
    
27.         Next
    
28.         .Range("a8:l100").ClearContents
    
29.         rw = 7
    
30.         For y = 0 To UBound(xx)
    
31.         rw = rw + 1
    
32.             For x = 1 To UBound(b)
    
33.                 .Cells(rw, b(x)).Value = arr(Val(xx(y)), x + 15)
    
34.             Next x
    
35.         Next y
    
36.         If Sheets("结果表").Range("a1") = "" Then
    
37.         .Range("a1:l" & rw).Copy Sheets("结果表").Range("a1")
    
38.         Else
    
39.             r2 = Sheets("结果表").Cells(Rows.Count, 1).End(3).Row + 2
    
40.             .Range("a1:l" & rw).Copy Sheets("结果表").Range("a" & r2)
    
41.         End If
    
42.     Next
    
43. End With
    
44. Sheet5.Activate
    
45. MsgBox "拆分结果在结果表"
    
46. End Sub
    

复制代码

Qs18

试试..............

Qs18

试试............