Sub s()
Dim rg1 As Range, rg2 As Range, c As Range
Set rg1 = Sheets("问1").[L5:XFD6]
Set rg2 = Sheets("问1结果").[D31:M69]
For Each c In rg1
If c <> "" Then
i = i + 1
rg2.Item(i) = c
End If
Next
End Sub
Sub Macro1()
Dim Rng As Range, Rng1 As Range, Dic As Object
Set Rng = Sheets(1).Range("B8:BJ8,B14:BJ14,B20:BJ20,B26:BJ26")
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets(2)
For Each Rng1 In Rng
If Not Dic.EXISTS(Rng1.Value) Then
Dic(Rng1.Value) = Dic.Count + 2
End If
.Cells(Rows.Count, Dic(Rng1.Value)).End(xlUp).Offset(1, 0) = Rng1
Next Rng1
End With
End Sub