Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 10103|回复: 15

[已解决]VBA矩阵排列组合

[复制链接]
发表于 2013-2-4 15:35 | 显示全部楼层 |阅读模式
本帖最后由 康三天衡 于 2013-2-4 15:36 编辑

未命名1.jpg
如图所示,A,B,C,D等为一个3*3的矩阵。实际使用中我是数字,可能有很多行很多列。我想如右边一样(是我复制黏贴的效果)持续的排列下去(因为矩阵很多。手工的话很耗费精力)。同行不排列。请问应该怎么弄。
最佳答案
2013-2-4 16:56
  1. Sub test2()
  2.     Dim arr() As Range, i&, LastRow&
  3.     Dim rg As Range
  4.     Dim iRow&, iCol&
  5.    
  6.     Application.ScreenUpdating = False
  7.     iRow = 1: iCol = 1
  8.     Range("q1").CurrentRegion.Clear
  9.     Do While iCol <> Columns.Count
  10.         iRow = 1
  11.         Do While iRow <> Rows.Count
  12.             Set rg = Cells(iRow, iCol)
  13.             Debug.Print rg.Address
  14.             i = i + 1
  15.             ReDim Preserve arr(1 To i)
  16.             Set arr(i) = rg.CurrentRegion
  17.             iRow = rg.End(xlDown).End(xlDown).Row
  18.         Loop
  19.         iCol = rg.End(xlToRight).End(xlToRight).Column
  20.     Loop
  21.     For iRow = 1 To i
  22.         For iCol = iRow + 1 To i
  23.             LastRow = Cells(Rows.Count, "q").End(xlUp).Row
  24.             If LastRow > 1 Then LastRow = LastRow + 1
  25.             If LastRow >= Rows.Count Then Exit Sub
  26.             arr(iRow).Copy Range("q" & LastRow)
  27.             
  28.             LastRow = Cells(Rows.Count, "q").End(xlUp).Row + 1
  29.             If LastRow >= Rows.Count Then Exit Sub
  30.             arr(iCol).Copy Range("q" & LastRow)
  31.             
  32.             LastRow = Cells(Rows.Count, "q").End(xlUp).Row + 1
  33.             If LastRow >= Rows.Count Then Exit Sub
  34.             arr(iCol).Copy Range("q" & LastRow)
  35.             
  36.             LastRow = Cells(Rows.Count, "q").End(xlUp).Row + 1
  37.             If LastRow >= Rows.Count Then Exit Sub
  38.             arr(iRow).Copy Range("q" & LastRow)
  39.         Next
  40.     Next
  41.     Range("q1").CurrentRegion.HorizontalAlignment = xlCenter
  42.     Application.ScreenUpdating = True
  43.     MsgBox "整理完成", vbInformation + vbOKOnly
  44. End Sub
复制代码
格式还是相差很大了。
发表于 2013-2-4 16:00 | 显示全部楼层
回复

使用道具 举报

 楼主| 发表于 2013-2-4 16:04 | 显示全部楼层
hwc2ycy 发表于 2013-2-4 16:00
就ABC重复?

未命名4.jpg
以次类推一个一个排列组合下去。同行不比较
回复

使用道具 举报

发表于 2013-2-4 16:06 | 显示全部楼层
传个附件吧。
回复

使用道具 举报

 楼主| 发表于 2013-2-4 16:15 | 显示全部楼层
综合累计.rar (40.87 KB, 下载次数: 39)
回复

使用道具 举报

 楼主| 发表于 2013-2-4 16:16 | 显示全部楼层
hwc2ycy 发表于 2013-2-4 16:06
传个附件吧。

附件我传了,麻烦给看下
回复

使用道具 举报

发表于 2013-2-4 16:49 | 显示全部楼层
  1. Option Explicit

  2. Sub test()
  3.     Dim arr(), i&, LastRow&
  4.     Dim rg As Range
  5.     Dim iRow&, iCol&
  6.    
  7.     Application.ScreenUpdating = False
  8.     iRow = 1: iCol = 1
  9.     Range("q1").CurrentRegion.Clear
  10.     Do While iCol <> Columns.Count
  11.         iRow = 1
  12.         Do While iRow <> Rows.Count
  13.             Set rg = Cells(iRow, iCol)
  14.             Debug.Print rg.Address
  15.             i = i + 1
  16.             ReDim Preserve arr(1 To i)
  17.             arr(i) = rg.CurrentRegion.Value
  18.             iRow = rg.End(xlDown).End(xlDown).Row
  19.         Loop
  20.         iCol = rg.End(xlToRight).End(xlToRight).Column
  21.     Loop
  22.     For iRow = 1 To i
  23.         For iCol = iRow + 1 To i
  24.             LastRow = Cells(Rows.Count, "q").End(xlUp).Row
  25.             If LastRow > 1 Then LastRow = LastRow + 1
  26.             If LastRow >= Rows.Count Then Exit Sub
  27.             Range("q" & LastRow).Resize(UBound(arr(iRow)), UBound(arr(iRow), 2)) = arr(iRow)
  28.             LastRow = Cells(Rows.Count, "q").End(xlUp).Row + 1
  29.             If LastRow >= Rows.Count Then Exit Sub
  30.             Range("q" & LastRow).Resize(UBound(arr(iCol)), UBound(arr(iCol), 2)) = arr(iCol)
  31.             LastRow = Cells(Rows.Count, "q").End(xlUp).Row + 1
  32.             If LastRow >= Rows.Count Then Exit Sub
  33.             Range("q" & LastRow).Resize(UBound(arr(iCol)), UBound(arr(iCol), 2)) = arr(iCol)
  34.             LastRow = Cells(Rows.Count, "q").End(xlUp).Row + 1
  35.             If LastRow >= Rows.Count Then Exit Sub
  36.             Range("q" & LastRow).Resize(UBound(arr(iRow)), UBound(arr(iRow), 2)) = arr(iRow)
  37.         Next
  38.     Next
  39.     Range("q1").CurrentRegion.HorizontalAlignment = xlCenter
  40.     Application.ScreenUpdating = True
  41.     MsgBox "整理完成", vbInformation + vbOKOnly
  42. End Sub
复制代码
无格式复制的。
回复

使用道具 举报

 楼主| 发表于 2013-2-4 16:55 | 显示全部楼层
hwc2ycy 发表于 2013-2-4 16:49
无格式复制的。

Option Explicit

Sub test()
    Dim arr(), i&, LastRow&
    Dim rg As Range
    Dim iRow&, iCol&

    Application.ScreenUpdating = False
    iRow = 1: iCol = 1
    Range("q1").CurrentRegion.Clear
    Do While iCol <> Columns.Count
        iRow = 1
        Do While iRow <> Rows.Count
            Set rg = Cells(iRow, iCol)
            Debug.Print rg.Address
            i = i + 1
            ReDim Preserve arr(1 To i)
            arr(i) = rg.CurrentRegion.Value
            iRow = rg.End(xlDown).End(xlDown).Row
        Loop
        iCol = rg.End(xlToRight).End(xlToRight).Column
    Loop
    For iRow = 1 To i
        For iCol = iRow + 1 To i
            LastRow = Cells(Rows.Count, "q").End(xlUp).Row
            If LastRow > 1 Then LastRow = LastRow + 1
            If LastRow >= Rows.Count Then Exit Sub
            Range("q" & LastRow).Resize(UBound(arr(iRow)), UBound(arr(iRow), 2)) = arr(iRow)
            LastRow = Cells(Rows.Count, "q").End(xlUp).Row + 1
            If LastRow >= Rows.Count Then Exit Sub
            Range("q" & LastRow).Resize(UBound(arr(iCol)), UBound(arr(iCol), 2)) = arr(iCol)
            LastRow = Cells(Rows.Count, "q").End(xlUp).Row + 1
            If LastRow >= Rows.Count Then Exit Sub
            Range("q" & LastRow).Resize(UBound(arr(iCol)), UBound(arr(iCol), 2)) = arr(iCol)
            LastRow = Cells(Rows.Count, "q").End(xlUp).Row + 1
            If LastRow >= Rows.Count Then Exit Sub
            Range("q" & LastRow).Resize(UBound(arr(iRow)), UBound(arr(iRow), 2)) = arr(iRow)
        Next
    Next
    Range("q1").CurrentRegion.HorizontalAlignment = xlCenter
    Application.ScreenUpdating = True
    MsgBox "整理完成", vbInformation + vbOKOnly
End Sub


我就这个代码复制过来,然后AFL+F11打开VBA插入模板,然后在EXCEL里面宏打开。但是运行后没有任何变化
回复

使用道具 举报

发表于 2013-2-4 16:56 | 显示全部楼层    本楼为最佳答案   
  1. Sub test2()
  2.     Dim arr() As Range, i&, LastRow&
  3.     Dim rg As Range
  4.     Dim iRow&, iCol&
  5.    
  6.     Application.ScreenUpdating = False
  7.     iRow = 1: iCol = 1
  8.     Range("q1").CurrentRegion.Clear
  9.     Do While iCol <> Columns.Count
  10.         iRow = 1
  11.         Do While iRow <> Rows.Count
  12.             Set rg = Cells(iRow, iCol)
  13.             Debug.Print rg.Address
  14.             i = i + 1
  15.             ReDim Preserve arr(1 To i)
  16.             Set arr(i) = rg.CurrentRegion
  17.             iRow = rg.End(xlDown).End(xlDown).Row
  18.         Loop
  19.         iCol = rg.End(xlToRight).End(xlToRight).Column
  20.     Loop
  21.     For iRow = 1 To i
  22.         For iCol = iRow + 1 To i
  23.             LastRow = Cells(Rows.Count, "q").End(xlUp).Row
  24.             If LastRow > 1 Then LastRow = LastRow + 1
  25.             If LastRow >= Rows.Count Then Exit Sub
  26.             arr(iRow).Copy Range("q" & LastRow)
  27.             
  28.             LastRow = Cells(Rows.Count, "q").End(xlUp).Row + 1
  29.             If LastRow >= Rows.Count Then Exit Sub
  30.             arr(iCol).Copy Range("q" & LastRow)
  31.             
  32.             LastRow = Cells(Rows.Count, "q").End(xlUp).Row + 1
  33.             If LastRow >= Rows.Count Then Exit Sub
  34.             arr(iCol).Copy Range("q" & LastRow)
  35.             
  36.             LastRow = Cells(Rows.Count, "q").End(xlUp).Row + 1
  37.             If LastRow >= Rows.Count Then Exit Sub
  38.             arr(iRow).Copy Range("q" & LastRow)
  39.         Next
  40.     Next
  41.     Range("q1").CurrentRegion.HorizontalAlignment = xlCenter
  42.     Application.ScreenUpdating = True
  43.     MsgBox "整理完成", vbInformation + vbOKOnly
  44. End Sub
复制代码
格式还是相差很大了。
回复

使用道具 举报

发表于 2013-2-4 16:59 | 显示全部楼层
综合累计.rar (14.74 KB, 下载次数: 88)
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-28 21:20 , Processed in 0.571313 second(s), 14 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表