如何将Sheet1表中学生成绩转换成Sheet2中的格式？

35610101

如何将Sheet1表中学生成绩转换成Sheet2中的格式？

lsc900707

Sub test()
    Dim ar, k, i%, n%, j%
    Set d = CreateObject("Scripting.Dictionary")
    With Sheets("sheet2")
        ar = .[a1].CurrentRegion
        For i = 2 To UBound(ar)
            s = ar(i, 1) & "@" & ar(i, 2) & "@" & ar(i, 3) & "@" & ar(i, 4)
            ss = ar(i, 5)
            If Not d.exists(s) Then
                Set d(s) = CreateObject("Scripting.Dictionary")
            End If
            d(s)(ss) = ar(i, 6)
        Next
    End With
    With Sheets("sheet1")
        .[a1].CurrentRegion.Offset(1).ClearContents
        ar = .[a1].Resize(10000, 13)
        n = 1
        For Each k In d.keys
            n = n + 1
            For i = 1 To 4
                ar(n, i) = Split(k, "@")(i - 1)
                For j = 5 To UBound(ar, 2)
                    ar(n, j) = d(k)(ar(1, j))
                Next
            Next
        Next
        .[a1].Resize(n, 13) = ar
    End With
End Sub

Qs18

Sub qs() '2024/7/1
    Dim arr, brr, i
    arr = Sheet1.UsedRange
    ReDim brr(1 To 10000, 1 To 6)
    For i = 2 To UBound(arr)
        For j = 5 To 13
            If arr(i, j) <> Empty Then
                m = m + 1
                brr(m, 1) = arr(i, 1): brr(m, 2) = arr(i, 2): brr(m, 3) = arr(i, 3): brr(m, 4) = arr(i, 4)
                brr(m, 5) = arr(1, j): brr(m, 6) = arr(i, j)
            End If
        Next
    Next
    Sheet2.Range("a2").Resize(m, 6) = brr
    MsgBox "ok!"
End Sub

Qs18

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

shiruiqiang

基本的数组

Qs18

试一下.............

wang-way

综评吧  哈哈哈哈

wang-way

1. Public Sub X1()
   
2.     Dim wb As Workbook, sht As Worksheet
   
3.     Set wb = Application.ThisWorkbook
   
4.     Set sht = wb.Worksheets(1)
   
5.     With sht
   
6.         Set Rng = .Range("A1").CurrentRegion
   
7.         arr = Rng.Value
   
8.     End With
   
9.     Dim br()
   
10.     ReDim br(1 To (UBound(arr) - 1) * 9 + 1, 1 To 6)
    
11.     br(1, 1) = "学部"
    
12.     br(1, 2) = "班级"
    
13.     br(1, 3) = "学生姓名"
    
14.     br(1, 4) = "证件号"
    
15.     br(1, 5) = "学科"
    
16.     br(1, 6) = "分数"
    
17.     r = 1
    
18.     For i = 2 To UBound(arr)
    
19.         For j = 5 To UBound(arr, 2)
    
20.             r = r + 1
    
21.             br(r, 1) = arr(i, 1)
    
22.             br(r, 2) = arr(i, 2)
    
23.             br(r, 3) = arr(i, 3)
    
24.             br(r, 4) = "'" & arr(i, 4)
    
25.             br(r, 5) = arr(1, j)
    
26.             br(r, 6) = arr(i, j)
    
27.         Next j
    
28.     Next i
    
29.     Set sht = wb.Worksheets(2)
    
30.     With sht
    
31.         .Range("a1").Resize(UBound(br), UBound(br, 2)).Value = br
    
32.     End With
    
33. End Sub
    

复制代码

usedrange

参与一下

1. Sub t()
   
2.     Dim arr, brr, m%, i%, j%, r%
   
3.     m = Sheet1.Range("a1").End(4).Row
   
4.     arr = Sheet1.Range("a1:m" & m)
   
5.     m = UBound(arr) * 9: r = 1
   
6.     ReDim brr(1 To m, 1 To 6)
   
7.     For i = 1 To UBound(arr) - 1
   
8.         For j = 5 To UBound(arr, 2)
   
9.             If arr(i + 1, j) <> "" Then
   
10.                 brr(r, 1) = arr(i + 1, 1)
    
11.                 brr(r, 2) = arr(i + 1, 2)
    
12.                 brr(r, 3) = arr(i + 1, 3)
    
13.                 brr(r, 4) = arr(i + 1, 4)
    
14.                 brr(r, 5) = arr(1, j)
    
15.                 brr(r, 6) = arr(i + 1, j)
    
16.                 r = r + 1
    
17.             End If
    
18.         Next j
    
19.     Next i
    
20.     Sheet2.[h2].Resize(UBound(brr), UBound(brr, 2)) = brr
    
21. End Sub

复制代码

35610101

Qs18 发表于 2024-7-1 07:12
试一下.............

这个可用，感谢！