二维表转换成一维表

gototom

在“实例”工作簿中，如何用VBA将“Sheet1”中的表（如图1）变为“Sheet2”中的样子（如图2）？
图1

图2

gototom

每人关注吗？

cjc209

=DROP(REDUCE("",A2:A6,LAMBDA(x,y,VSTACK(x,IFERROR(HSTACK(y,TOCOL(OFFSET(y,,1,1,4))),"")))),1)

cjc209

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, i&, j&, r&
   
    Application.ScreenUpdating = False
   
    ar = Worksheets(1).[A1].CurrentRegion.Value
    ReDim br(UBound(ar) * UBound(ar), 1 To 2)
    br(0, 1) = "题干": br(0, 2) = "选项"
   
    For i = 2 To UBound(ar)
        For j = 2 To UBound(ar, 2)
            r = r + 1
            If j = 2 Then br(r, 1) = ar(i, 1)
            br(r, 2) = ar(i, j)
        Next j
    Next i
      
    With Worksheets(2)
        With .Cells
            .ClearContents
            .Borders.LineStyle = xlNone
        End With
        With .[A1].Resize(r + 1, 2)
            .Value = br
             .Borders.LineStyle = xlContinuous
        End With
        .Activate
    End With
   
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考。。。

cjc209

jsa 自定义函数完成

lizhipei78

比较简单的一道题目，练习一下

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.12.21
   
2.     With Sheets("Sheet1")
   
3.         r = .Cells(Rows.Count, 1).End(3).Row
   
4.         arr = .[a1].Resize(r, 5)
   
5.     End With
   
6.     ReDim brr(1 To 10000, 1 To 2)
   
7.     For i = 2 To UBound(arr)
   
8.         m = m + 1
   
9.         brr(m, 1) = arr(i, 1)
   
10.         brr(m, 2) = arr(i, 2)
    
11.         For j = 3 To UBound(arr, 2)
    
12.             m = m + 1
    
13.             brr(m, 2) = arr(i, j)
    
14.         Next
    
15.     Next
    
16.     With Sheets("Sheet2")
    
17.         .UsedRange.Offset(1).ClearContents
    
18.         .[a2].Resize(m, 2) = brr
    
19.         .[a2].Resize(m, 2).Borders.LineStyle = 1
    
20.     End With
    
21.     MsgBox "OK！"
    
22. End Sub
    

复制代码