如何实现自动分栏形成以下效果

bcly

在网上看到一遍文章，将数据进行自动分栏，感觉挺好，也实现了自动分栏，但班与班学生数据不能区分开，如何实现以下图中效果分栏的同时将班与班学生之间进行分页



Sub 自动分栏()
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Set sh1 = Sheets("原数据")
    Set sh2 = Sheets("分栏数据")
    ar = sh1.Range("a1").CurrentRegion
    p = sh2.[h1] '每页行数
    h = sh2.[j1] '行高
    j = 1 '记录行数
    ActiveSheet.ResetAllPageBreaks '重置分页符
    sh2.Range("a2:f65535").ClearContents '清空数据
    For i = 2 To UBound(ar)
        If j > p * 2 Then '判断第二栏是否结束
            j = 1 '初始化行数
        End If
        If j = p Then '判断第一栏是否结束
            sh2.HPageBreaks.Add Before:=Range("A" & r + 2) '设置分页符
            sh2.Rows("2:" & r + 1).RowHeight = h '设置行高
        End If
        If j <= p Then '判断页行数是否大于指定行数
            c = 1 '第一栏A列开始
        Else
            c = 1 + UBound(ar, 2) '第二栏开始位置
        End If
        r = sh2.Cells(65535, c).End(3).Row + 1 '获取最后一行的下一行
        For k = 1 To UBound(ar, 2)
           sh2.Cells(r, c + k - 1) = ar(i, k) '写入数据
        Next
        j = j + 1 '行数累加
    Next
    MsgBox "分栏完成！"
End Sub

wang-way

如果一个班的学生不是特别多，调整一下分页符也是可以的，又或者你把纸张调整成横向，一个班一张纸也可以。在外面没电脑，回家弄一下。

titi012

参与一下。。。。

1. Sub test()
   
2.     Dim Arr, Brr(), x&, y&, i&, j&
   
3.     Dim M&, R&, C&, N&, H As Double
   
4.     Arr = Sheets("原数据").Range("a1").CurrentRegion
   
5.     ReDim Brr(1 To UBound(Arr), 1 To 6)
   
6.     With Sheets("分栏数据")
   
7.         M = .[h1] '行数
   
8.         .ResetAllPageBreaks '重置分页符
   
9.         .Range("a2:f65535").ClearContents '清空数据
   
10.         .Cells.RowHeight = .[j1]
    
11.         For i = 2 To UBound(Arr)
    
12.             If Arr(i, 3) <> Arr(i - 1, 3) Then N = N + 1: x = 1 Else x = x + 1
    
13.             If x = M * 2 + 1 Then N = N + 1
    
14.             C = (Int(x / (M + 0.1)) Mod 2) * 3
    
15.             R = N * M - M + ((x - 1) Mod M) + 1
    
16.             For j = 1 To 3
    
17.                 Brr(R, C + j) = Arr(i, j)
    
18.             Next
    
19.             If Arr(i, 3) <> Arr(i - 1, 3) And i > 2 Then .HPageBreaks.Add Before:=Range("A" & R + 1) '设置分页符
    
20.         Next i
    
21.         .Range("A2").Resize(R, 6) = Brr
    
22.     End With
    
23. End Sub

复制代码

wang-way

彻底解决问题

wang-way