一维表转为二维表

adud

将一维表转为二维表，前面考生号、姓名、班级应该都能看懂，后面的考试科目1到11，顺序可以不管，只要将每个人对应的科目筛出来就行。若是能按语文、数学、英语、物理、化学、生物、历史、政治、地理、信息技术、思想政治、这样的顺序更好。

数据较多，一个一个的复制太慢了，求助大神帮忙解决。谢谢

adud

左侧为原数据，右侧的为目标格式。

盼盼198310

是不是这样

2324

插入数据透视表？

adud

盼盼198310 发表于 2022-2-15 12:30
是不是这样

我也勉强解决了这个问题，但是若是第一列号码若不在一起，就会出错，所以必须提前按号码排序。我把代码贴出来，期待各位指点指点。先谢谢您的帮助。Sub test2()
Dim i%, j%, k%, l%, x%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
x = Range("a65536").End(xlUp).Row
Range("A2").Select
    ActiveWorkbook.Worksheets("123").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("123").Sort.SortFields.Add Key:=Range("A2:A" & x), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("123").Sort
        .SetRange Range("A1:D" & x)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
brr = Sheet1.Range("a2:d" & [A65536].End(3).Row)
For i = 1 To UBound(brr)
       If d.exists(brr(i, 1) & brr(i, 4)) Then
        MsgBox brr(i, 1) & "," & brr(i, 4) & "," & "存在重复"
       Else
        d(brr(i, 1) & brr(i, 4)) = ""
       End If
    Next
d.RemoveAll
   For i = 1 To UBound(brr)
        If d.exists(brr(i, 1)) Then
            d(brr(i, 1)) = d(brr(i, 1)) + 1
        Else
            d(brr(i, 1)) = 1
        End If

    Next i
j = d.Count
m = d.keys
n = d.items
d.RemoveAll
ReDim arr(1 To j, 1 To 15)
    For i = 1 To UBound(brr)
        If d.exists(brr(i, 1)) Then
            d(brr(i, 1)) = d(brr(i, 1)) + 1
            arr(k, l) = brr(i, 4)
            l = l + 1
        Else
            d(brr(i, 1)) = 1
            k = k + 1
            arr(k, 1) = brr(i, 1): arr(k, 2) = brr(i, 2):
            arr(k, 3) = n(k - 1)
            arr(k, 4) = brr(i, 3): arr(k, 5) = brr(i, 4)
            l = 6
        End If

    Next i



Range("g2").Resize(UBound(arr, 1), UBound(arr, 2)).ClearContents
Range("g2").Resize(UBound(arr, 1), UBound(arr, 2)) = arr

End Sub

adud

盼盼198310 发表于 2022-2-15 12:30
是不是这样

Sub test2()
Dim i%, j%, k%, l%, x%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
x = Range("a65536").End(xlUp).Row
Range("A2").Select
    ActiveWorkbook.Worksheets("123").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("123").Sort.SortFields.Add Key:=Range("A2:A" & x), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("123").Sort
        .SetRange Range("A1:D" & x)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
brr = Sheet1.Range("a2:d" & [A65536].End(3).Row)
For i = 1 To UBound(brr)
       If d.exists(brr(i, 1) & brr(i, 4)) Then
        MsgBox brr(i, 1) & "," & brr(i, 4) & "," & "存在重复"
       Else
        d(brr(i, 1) & brr(i, 4)) = ""
       End If
    Next
d.RemoveAll
   For i = 1 To UBound(brr)
        If d.exists(brr(i, 1)) Then
            d(brr(i, 1)) = d(brr(i, 1)) + 1
        Else
            d(brr(i, 1)) = 1
        End If
   
    Next i
j = d.Count
m = d.keys
n = d.items
d.RemoveAll
ReDim arr(1 To j, 1 To 15)
    For i = 1 To UBound(brr)
        If d.exists(brr(i, 1)) Then
            d(brr(i, 1)) = d(brr(i, 1)) + 1
            arr(k, l) = brr(i, 4)
            l = l + 1
        Else
            d(brr(i, 1)) = 1
            k = k + 1
            arr(k, 1) = brr(i, 1): arr(k, 2) = brr(i, 2):
            arr(k, 3) = n(k - 1)
            arr(k, 4) = brr(i, 3): arr(k, 5) = brr(i, 4)
            l = 6
        End If
   
    Next i



Range("g2").Resize(UBound(arr, 1), UBound(arr, 2)).ClearContents
Range("g2").Resize(UBound(arr, 1), UBound(arr, 2)) = arr

End Sub

adud

adud 发表于 2022-2-15 13:09
我也勉强解决了这个问题，但是若是第一列号码若不在一起，就会出错，所以必须提前按号码排序。我把代码贴 ...

我把我的贴出来，期待各位指点指点。
Sub test2()
Dim i%, j%, k%, l%, x%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
x = Range("a65536").End(xlUp).Row
Range("A2").Select
    ActiveWorkbook.Worksheets("123").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("123").Sort.SortFields.Add Key:=Range("A2:A" & x), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("123").Sort
        .SetRange Range("A1:D" & x)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
brr = Sheet1.Range("a2:d" & [A65536].End(3).Row)
For i = 1 To UBound(brr)
       If d.exists(brr(i, 1) & brr(i, 4)) Then
        MsgBox brr(i, 1) & "," & brr(i, 4) & "," & "存在重复"
       Else
        d(brr(i, 1) & brr(i, 4)) = ""
       End If
    Next
d.RemoveAll
   For i = 1 To UBound(brr)
        If d.exists(brr(i, 1)) Then
            d(brr(i, 1)) = d(brr(i, 1)) + 1
        Else
            d(brr(i, 1)) = 1
        End If
   
    Next i
j = d.Count
m = d.keys
n = d.items
d.RemoveAll
ReDim arr(1 To j, 1 To 15)
    For i = 1 To UBound(brr)
        If d.exists(brr(i, 1)) Then
            d(brr(i, 1)) = d(brr(i, 1)) + 1
            arr(k, l) = brr(i, 4)
            l = l + 1
        Else
            d(brr(i, 1)) = 1
            k = k + 1
            arr(k, 1) = brr(i, 1): arr(k, 2) = brr(i, 2):
            arr(k, 3) = n(k - 1)
            arr(k, 4) = brr(i, 3): arr(k, 5) = brr(i, 4)
            l = 6
        End If
   
    Next i



Range("g2").Resize(UBound(arr, 1), UBound(arr, 2)).ClearContents
Range("g2").Resize(UBound(arr, 1), UBound(arr, 2)) = arr

End Sub

夏天的风shh4695

application.worksheetfunction.transpose

cjc209

Sub 一维转二维()
    Dim Arr, 结果数组(), i As Long, k As Long, 关键字 As String, dic As Object
    Arr = Sheets("123").[a1].CurrentRegion '原始数据装入数组
    ReDim 结果数组(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    Set dic = CreateObject("scripting.dictionary")
    For i = 2 To UBound(Arr, 1) '跳过标题行
        关键字 = Arr(i, 1) & "|" & Arr(i, 2) & "|" & Arr(i, 3)
        If Not dic.Exists(关键字) Then
            k = k + 1
            dic(关键字) = k '记录关键字所在结果数组中的行号位置
            结果数组(k, 1) = "'" & Arr(i, 1) '每个关键字匹配的值在一个单元格内输出
            结果数组(k, 2) = Arr(i, 2)
            结果数组(k, 3) = Arr(i, 3)
            结果数组(k, 4) = Arr(i, 4) '为要透视的那一列
        Else
            结果数组(dic(关键字), 4) = 结果数组(dic(关键字), 4) & "|" & Arr(i, 4)
        End If
    Next
    [A2].Resize(10000, 100).ClearContents
    [A2].Resize(k, UBound(Arr, 2)) = 结果数组
    [A2].Offset(0, 3).Resize(k, 1).TextToColumns Destination:=[g2].Offset(0, 3), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="|", TrailingMinusNumbers:=True
End Sub

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   Set d1 = CreateObject("scripting.dictionary")
   
7.   n = 0
   
8.   For Each aa In Array("语文", "数学", "外语", "物理", "化学", "生物", "历史", "政治", "地理", "信息技术", "思想政治")
   
9.     n = n + 1
   
10.     d1(aa) = n
    
11.   Next
    
12.   With Worksheets("123")
    
13.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
14.     arr = .Range("a2:d" & r)
    
15.     .Columns(7).NumberFormatLocal = "@"
    
16.     For i = 1 To UBound(arr)
    
17.       If Not d.exists(arr(i, 1)) Then
    
18.         ReDim brr(1 To 4)
    
19.         For j = 1 To 4
    
20.           brr(j) = arr(i, j)
    
21.         Next
    
22.       Else
    
23.         brr = d(arr(i, 1))
    
24.         m = UBound(brr) + 1
    
25.         ReDim Preserve brr(1 To m)
    
26.         brr(m) = arr(i, 4)
    
27.       End If
    
28.       d(arr(i, 1)) = brr
    
29.     Next
    
30.     m = 1
    
31.     For Each aa In d.keys
    
32.       brr = d(aa)
    
33.       For i = 4 To UBound(brr) - 1
    
34.         p = i
    
35.         For j = i + 1 To UBound(brr)
    
36.           If d1(brr(p)) > d1(brr(j)) Then
    
37.             p = j
    
38.           End If
    
39.         Next
    
40.         If p <> i Then
    
41.           temp = brr(i)
    
42.           brr(i) = brr(p)
    
43.           brr(p) = temp
    
44.         End If
    
45.       Next
    
46.       m = m + 1
    
47.       .Cells(m, 7).Resize(1, UBound(brr)) = brr
    
48.     Next
    
49.   End With
    
50. End Sub
    

复制代码