如何使我的相对宏每隔三行运行一次

Question

感谢您的光临。

欢迎所有建议我是个新手。

我做了一个很长的（而且效率很低的宏来移动数据。）

它可以正确地将三列移动到三行中几次。问题是，我需要它适用于每4行运行约1000行。

我想我在找一个循环。。不完全确定。我也很感激有一种引用的方式，这样我就不需要一次又一次地重复了，因为这会让事情变慢。

Sub FullMacro()
'Copy info over
    Cells.Select
    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    Cells.Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
' Deletes Top Row
    Rows("1:35").Select
    Selection.Delete Shift:=xlUp
        
 ' InsertColumns Macro
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
    Columns("z:z").Select
    Selection.Insert Shift:=xlToRight
    Columns("AX:AX").Select
    Selection.Insert Shift:=xlToRight
    Selection.Insert Shift:=xlToRight
    Columns("BA:BA").Select
    Selection.Insert Shift:=xlToRight
    Selection.Insert Shift:=xlToRight
    Columns("BE:BE").Select
    Selection.Insert Shift:=xlToRight
    Columns("BG:BG").Select
    Selection.Insert Shift:=xlToRight
    
'This moves the titles to a single long row
    Range("A2").Select
    Selection.Cut Destination:=Range("B1")
    Range("A3").Select
    Selection.Cut Destination:=Range("C1")
    Range("D2").Select
    Selection.Cut Destination:=Range("E1")
    Range("D3").Select
    Selection.Cut Destination:=Range("F1")
    Range("K2").Select
    Selection.Cut Destination:=Range("L1")
    Range("K3").Select
    Selection.Cut Destination:=Range("M1")
    Range("R3").Select
    Selection.Cut Destination:=Range("T1")
    Range("T1").Select
    Range("Y2").Select
    Selection.Cut Destination:=Range("Z1")
    Range("Y3").Select
    Selection.Cut Destination:=Range("AA1")
    Range("AB2").Select
    Selection.Cut Destination:=Range("AC1")
    Range("AB3").Select
    Selection.Cut Destination:=Range("AD1")
    Range("AJ2").Select
    Selection.Cut Destination:=Range("AK1")
    Range("AJ3").Select
    Selection.Cut Destination:=Range("AL1")
    Range("AM2").Select
    Selection.Cut Destination:=Range("AN1")
    Range("AM3").Select
    Selection.Cut Destination:=Range("AO1")
    Range("AO1").Select
    Range("AS2").Select
    Selection.Cut Destination:=Range("AT1")
    Range("AS3").Select
    Selection.Cut Destination:=Range("AU1")
    Range("AW2").Select
    Selection.Cut Destination:=Range("AX1")
    Range("AW3").Select
    Selection.Cut Destination:=Range("AY1")
    Range("AZ2").Select
    Selection.Cut Destination:=Range("BA1")
    Range("AZ3").Select
    Selection.Cut Destination:=Range("BB1")
    Range("BD2").Select
    Selection.Cut Destination:=Range("BE1")
    Range("BF2").Select
    Selection.Cut Destination:=Range("BG1")
    Range("BG1").Select
    
' Deletes the colums we don't need
    
    Columns("H:J").Select
    Selection.Delete Shift:=xlToLeft
    Columns("L:N").Select
    Selection.Delete Shift:=xlToLeft
    Columns("M:M").Select
    Selection.Delete Shift:=xlToLeft
    Columns("N:Q").Select
    Selection.Delete Shift:=xlToLeft
    Columns("T:X").Select
    Selection.Delete Shift:=xlToLeft
    Columns("Z:AB").Select
    Selection.Delete Shift:=xlToLeft
    Columns("AC:AC").Select
    Selection.Delete Shift:=xlToLeft
           
' Deletes the rows which used to have the titles in them
    Rows("2:3").Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
           
End Sub
Sub Mover()
'Moves the actual contents into the single row formatt
    Range("A1").Select
    ActiveCell.Offset(2, 0).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-1, 1).Range("A1")
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-2, 2).Range("A1")
    ActiveCell.Offset(-1, 3).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-1, 1).Range("A1")
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-2, 2).Range("A1")
    ActiveCell.Offset(-1, 4).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-1, 1).Range("A1")
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-2, 2).Range("A1")
    ActiveCell.Offset(0, 4).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-2, 1).Range("A1")
    ActiveCell.Offset(-1, 2).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-1, 1).Range("A1")
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-2, 2).Range("A1")
    ActiveCell.Offset(-1, 3).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-1, 1).Range("A1")
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-2, 2).Range("A1")
    ActiveCell.Offset(-1, 3).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-1, 1).Range("A1")
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-2, 2).Range("A1")
    ActiveCell.Offset(-1, 3).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-1, 1).Range("A1")
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-2, 2).Range("A1")
    ActiveCell.Offset(-1, 3).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-1, 1).Range("A1")
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-2, 2).Range("A1")
    ActiveCell.Offset(-1, 3).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-1, 1).Range("A1")
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-2, 2).Range("A1")
    ActiveCell.Offset(-1, 3).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-1, 1).Range("A1")
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-2, 2).Range("A1")
    ActiveCell.Offset(-1, 4).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-1, 1).Range("A1")
    ActiveCell.Offset(0, 2).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-1, 1).Range("A1")
  
End Sub
'At the moment I have to repeat downwards by selecting a new active cell and running again. This is what I want to fix. 
    Sub looping()
    Range("A5").Select
    
    ActiveCell.Offset(2, 0).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-1, 1).Range("A1")
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-2, 2).Range("A1")
    ActiveCell.Offset(-1, 3).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-1, 1).Range("A1")
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-2, 2).Range("A1")
    ActiveCell.Offset(-1, 4).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-1, 1).Range("A1")
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-2, 2).Range("A1")
    ActiveCell.Offset(0, 4).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-2, 1).Range("A1")
    ActiveCell.Offset(-1, 2).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-1, 1).Range("A1")
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-2, 2).Range("A1")
    ActiveCell.Offset(-1, 3).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-1, 1).Range("A1")
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-2, 2).Range("A1")
    ActiveCell.Offset(-1, 3).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-1, 1).Range("A1")
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-2, 2).Range("A1")
    ActiveCell.Offset(-1, 3).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-1, 1).Range("A1")
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-2, 2).Range("A1")
    ActiveCell.Offset(-1, 3).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-1, 1).Range("A1")
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-2, 2).Range("A1")
    ActiveCell.Offset(-1, 3).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-1, 1).Range("A1")
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-2, 2).Range("A1")
    ActiveCell.Offset(-1, 3).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-1, 1).Range("A1")
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-2, 2).Range("A1")
    ActiveCell.Offset(-1, 4).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-1, 1).Range("A1")
    ActiveCell.Offset(0, 2).Range("A1").Select
    Selection.Cut Destination:=ActiveCell.Offset(-1, 1).Range("A1")

Answer 1

我很快就忘记了你的代码中发生了什么，所以我很确定我没有完全理解你的问题？我知道它应该发表评论，但我没有足够的代表。

我假设每四行都是由于将列移动到行中？如果是这样，您可以颠倒顺序，从底部的列开始向上移动。举个例子，我想把它移到一张新的纸上，但这可以很快解决：

Sub ColumnsToRow()
    Set oldWs = ActiveSheet

    'Assuming you want to start in the active selected cell, if it is always a fixed starting point then this should be updated
    'Row and Column index of activecell
    vcol = ActiveCell.Column
    vRow = ActiveCell.Row
    'get the last row in the selected column
    maxLastRow = oldWs.UsedRange.Rows.Count '~~> the last row index can not be higher that max row index in the sheet
    Set veryLastIndex = oldWs.Range(oldWs.Cells(maxLastRow + 1, vcol), oldWs.Cells(maxLastRow + 1, vcol)) '~~> sets the range object to the cell indexed one higher than the max row index
    lastRowInColumn = veryLastIndex.End(xlUp).Row '~~> go up from the veryLastIndex
    Set newWs = Worksheets.Add
    For i = lastRowInColumn To vRow Step -1
        'insert two rows below
        newWs.Cells(i, vcol).Offset(1).EntireRow.Insert
        newWs.Cells(i, vcol).Offset(1).EntireRow.Insert
            'move the cells into the newly created rows
            For j = 0 To 2
                oldWs.Cells(i, vcol + j).Copy Destination:=newWs.Cells(i + j, vcol)
            Next        
    Next
End Sub

如果你能添加更多的描述，也许还可以添加before->after的屏幕截图，那就太好了。