EXCELVBA如何把几列按顺序排成了行

Sub 排列()
Dim lie As Integer
Dim maxhang As Integer
Dim maxlie As Integer
Dim minhang As Integer
Dim minlie As Integer
Dim mubiaohang As Integer
lie = 1 '设置图2效果开始列。
mubiaohang = 10 '设置图2效果开始行
maxhang = 5 '设置图1数据最后一行。
maxlie = 8 '设置图1有数据的最大列
minhang = 1 '设置图1有数据的起始行
minlie = 1 '设置图1起始列
For i = minlie To maxhang
For a = minhang To maxlie
Cells(mubiaohang, lie) = Cells(a, i)
lie = lie + 1
Next
Next
End Sub
根据你表格的数据修改那几个设置的参数就可以了。

33个中取任意4个的宏如下：
Sub test()
Dim i, j, k, l As Byte
ApplicationScreenUpdating = False
Cells(1, 1)Select
For i = 1 To 30
For j = i + 1 To 31
For k = j + 1 To 32
For l = k + 1 To 33
Selection = i
SelectionOffset(0, 1) = j
SelectionOffset(0, 2) = k
SelectionOffset(0, 3) = l
SelectionOffset(1, 0)Select
Next
Next
Next
Next
ApplicationScreenUpdating = True
End Sub
33个中取任意3个的宏如下：
Sub test()
Dim i, j, k As Byte
ApplicationScreenUpdating = False
Cells(1, 1)Select
For i = 1 To 31
For j = i + 1 To 32
For k = j + 1 To 33
Selection = i
SelectionOffset(0, 1) = j
SelectionOffset(0, 2) = k
SelectionOffset(1, 0)Select
Next
Next
Next
ApplicationScreenUpdating = True
End Sub
33个中取任意2个的宏如下：
Sub test()
Dim i, j As Byte
ApplicationScreenUpdating = False
Cells(1, 1)Select
For i = 1 To 32
For j = i + 1 To 33
Selection = i
SelectionOffset(0, 1) = j
SelectionOffset(1, 0)Select
Next
Next
ApplicationScreenUpdating = True
End Sub
在2007版中，还可以实现取5个的，自己对照修改吧。取6个以上，格子不够。

增加一个工作表sheet3，用以下代码即可按要求重新排列到sheet3。

Sub 排序()
Dim Ra1 As Range, Ra2 As Range, S$
Sheet3UsedRangeEntireRowDelete
Sheet1Rows(1)Copy Sheet3Range("A1")
For Each Ra2 In Sheet2Range("B2", Sheet2Range("B65536")End(3))
   Set Ra1 = Sheet1Range("A:A")Find(Ra2, , , 2)
   If Ra1 Is Nothing Then
      S = S & Chr(10) & Ra2Offset(, -1) & "、" & Ra2
   Else
      Ra1CurrentRegionCopy Sheet3Range("B65536")End(3)Offset(2, -1)
   End If
Next
If S <> "" Then MsgBox "以下项目没找到：" & S
End Sub

因为截图不全，我这里先假设数据区为A1:F9, 填充区为H1:M9

代码如下：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim arr1(1 To 54), arr2(1 To 54)

Dim x, y, z As Integer

Dim b, c

Dim a As Variant

z = 1

x = 1

y = 1

c = 1

For x = 1 To 9

For y = 1 To 6

arr1(z) = Cells(x, y)

z = z + 1

Next y

Next x

z = z - 1

For z = 1 To 54

a = arr1(z)

b = z

For x = 1 To 54

 If a < arr1(x) Then

  a = arr1(x)

  b = x

 End If

Next x

arr2(c) = a

c = c + 1

arr1(b) = 0

Next z

c = c - 1

For x = 1 To 9

For y = 8 To 13

Cells(x, y) = arr2(c)

c = c - 1

Next y

Next x

End Sub

运行结果

如帮到你请点个采纳，谢谢^_^

---