求助如何将数据分成指定列数到指定位置，保留字体颜色

eflys666

我有一个总表，如图



想将总表数据分到指定列数，并保留源格式




求教大家如何实现，VBA、函数都可以

素材下载：

3190496160

看是简单，其实很繁琐，先留个记号吧

么么哒＾3＾

你直接粘不就行了吗？

eflys666

么么哒＾3＾ 发表于 2024-8-1 10:27
你直接粘不就行了吗？

数据少可以，数据多了复制粘贴很繁琐，眼镜都看嘛了

eflys666

3190496160 发表于 2024-8-1 09:30
看是简单，其实很繁琐，先留个记号吧

感谢，有时间时麻烦研究一下

3190496160

eflys666 发表于 2024-8-1 12:27
感谢，有时间时麻烦研究一下

问题肯定是可以解决的，只是耗时耗力而已，但是，很多细节是不明确的，不妨加v沟通

3190496160

Sub 分表()
Set sh = Sheets("八总")
With sh
     r = .Cells(Rows.Count, 2).End(xlUp).Row
     ar = .[a1].Resize(r, 22)
     mc = Replace(.Name, "总", "分")
End With
With Sheets("八分")
    .UsedRange.Borders.LineStyle = 0
    .UsedRange.UnMerge
    .UsedRange = Empty
    .Select
     For i = 3 To UBound(ar) Step 2
        m = 0
        n = 0
        ReDim br(1 To UBound(ar) * 3, 1 To 7)
        br(1, 1) = ar(i, 1)
        rs = .Cells(Rows.Count, 2).End(xlUp).Row + 2
        If rs = 3 Then rs = 1
        br(2, 2) = "节次"
        If ar(i, 1) <> "" Then
            For j = 3 To UBound(ar, 2) Step 5
                m = m + 1
                y = 2
                If m = 1 Then
                    n = n + 4
                    For s = j To j + 4
                        y = y + 1
                        br(n - 3, y) = ar(2, s)
                        br(n - 2, y) = ar(1, s)
                        br(n - 1, y) = ar(i, s)
                        br(n, y) = ar(i + 1, s)
                        br(n - 1, 2) = ar(i, 2)
                        br(n, 2) = ar(i + 1, 2)
                    Next s
                    n = n + 1
                Else
                    n = n + 3
                    br(n - 2, 2) = "节次"
                    For s = j To j + 4
                        y = y + 1
                        br(n - 2, y) = ar(1, s)
                        br(n - 1, y) = ar(i, s)
                        br(n, y) = ar(i + 1, s)
                        br(n - 1, 2) = ar(i, 2)
                        br(n, 2) = ar(i + 1, 2)
                    Next s
                    n = n + 1
                End If
            Next j
            .Cells(rs, 1).Resize(1, 7).Select
            With Selection
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .MergeCells = False
            End With
            Selection.Merge
            .Cells(rs, 1) = "******表"
            .Cells(rs + 1, 1).Resize(n - 1, 7) = br
            .Cells(rs + 1, 1).Resize(n - 1, 7).Borders.LineStyle = 1
        End If
    Next i
End With
MsgBox "ok!"
End Sub

3190496160

样例数据11.rar (26.68 KB, 下载次数: 1)

2024-8-3 10:42 上传

点击文件名下载附件

3190496160

一个初稿，仅供参考
合并单元格和字体颜色的代码还没写，

eflys666

3190496160 发表于 2024-8-3 10:43
一个初稿，仅供参考
合并单元格和字体颜色的代码还没写，

感谢大佬热心帮助，主题这效果还不错，单元格合并效果不错，字体颜色应该加入小部分代码修改就可以