|
楼主 |
发表于 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里面宏打开。但是运行后没有任何变化
|
|