如何让我的相对宏在每第3行运行？

时间：2014-10-16 10:08:11

标签： loops excel-vba vba excel

感谢您一看。

欢迎所有建议我是新手。

我制作了一个非常长（效率低下的宏来移动数据。）

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

我想我正在寻找一个循环..不完全确定。也会欣赏一种引用方式，所以我不需要再重复它，因为它会减慢速度。

＆＃13;
＆＃13; 
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")
＆＃13;
＆＃13;
＆＃13;

1 个答案:

答案 0 :(得分：0)

我很快就忘记了你的代码中发生了什么，所以我很确定我不明白你的问题的全部范围？我知道它应该是评论，但我没有足够的代表。

我假设每隔四行是由于移动列成行？如果是这样，您可以撤销订单并从底部列开始向上移动。为了举例，我将其移动到新的工作表中，但可以快速修复：

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

如果您可以添加更多描述，也许还可以添加之前的屏幕截图 - ＆gt;之后会很棒。

相关问题
最新问题