求大神通过VBA代码操作实现成绩表的插入

vba韭菜

模板文件已上传，内有处理前原始工作表和处理后的实现效果工作表

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf() '//2024.4.17
   
2.     arr = Sheets("原始1").UsedRange
   
3.     brr = Sheets("原始2").UsedRange
   
4.     ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2) + UBound(brr, 2))
   
5.     For i = 1 To UBound(arr)
   
6.         m = m + 1
   
7.         n = 1
   
8.         crr(m, 1) = arr(i, 1)
   
9.         For j = 2 To UBound(arr, 2)
   
10.             n = n + 1
    
11.             crr(m, n) = arr(i, j)
    
12.             n = n + 1
    
13.             crr(m, n) = brr(i, j)
    
14.         Next
    
15.     Next
    
16.     With Sheets("修改后的原始1")
    
17.         .Cells.ClearContents
    
18.         .[a1].Resize(m, n) = crr
    
19.     End With
    
20.     MsgBox "OK！"
    
21. End Sub
    

复制代码

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     With Worksheets("原始2")
   
4.         .AutoFilterMode = False
   
5.         c = .Cells(1, .Columns.Count).End(xlToLeft).Column
   
6.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
7.         With Worksheets("原始1")
   
8.             c1 = .Cells(1, .Columns.Count).End(xlToLeft).Column
   
9.             If c <> c1 Then
   
10.                 MsgBox "两份原始表格数据列数不一样！"
    
11.                 Exit Sub
    
12.             End If
    
13.         End With
    
14.         For j = c To 2 Step -1
    
15.             With Worksheets("原始1")
    
16.                 .Columns(j + 1).Insert shift:=xlToRight
    
17.                 Worksheets("原始2").Cells(1, j).Resize(r, 1).Copy Destination:=.Cells(1, j + 1)
    
18.             End With
    
19.         Next
    
20.             
    
21.     End With
    
22. End Sub
    

复制代码

chxw68

参与一下。

Qs18

成绩表.rar (73.6 KB, 下载次数: 9)

2024-4-17 15:51 上传

点击文件名下载附件
供参考

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, j&
   
    Cells.Delete
    With Sheets("原始1")
        ar = .[A1].CurrentRegion.Value
        .Columns(1).Copy [A1]
        For j = 2 To UBound(ar, 2)
            .Columns(j).Copy Cells((j - 1) * 2)
        Next j
    End With
        With Sheets("原始2")
        ar = .[A1].CurrentRegion.Value
        .Columns(1).Copy [A1]
        For j = 2 To UBound(ar, 2)
            .Columns(j).Copy Cells((j - 1) * 2 + 1)
        Next j
    End With
    Beep
End Sub

gwjkkkkk

参与一下。。。

常扬帆

gwjkkkkk 发表于 2024-4-17 20:22
参与一下。。。

您好！我在后面加了体育，也能完美合并！我没理解错的话，这应该可以理解为期中、期末考试汇集。我想说的是，如果把原始一、原始二，变成一季度、二季度、三季度、四季度，又或一月、二月……12月的业绩，并且姓名打乱了或者有的姓名缺失呢？您能写个代码吗？谢谢您先！

gwjkkkkk

常扬帆 发表于 2024-4-17 20:56
您好！我在后面加了体育，也能完美合并！我没理解错的话，这应该可以理解为期中、期末考试汇集。我想说的 ...

1.如果把原始一、原始二，变成一季度、二季度、三季度、四季度，又或一月、二月……12月的业绩，可能事先定义一个数组作为表名，遍历取数。
2.名字打乱，可以用字典来定位
3.建议数组方式来写代码。