Question

因此，我有一张很长的桌子，我想在一页上容纳每90个单元格。我试图编写一个循环来一次复制和粘贴每45行，但是我真的不知道该怎么做。任何帮助都感激不尽！预先谢谢你。

Sub Macro2()

    Range("A47:C92").Select         (I selected 45 rows a time)
    Selection.Cut
    Range("E1").Select             
    ActiveSheet.Paste
    Columns("F:F").ColumnWidth = 15.67
    Range("A47:C92").Select
    Selection.Delete Shift:=xlUp

    Range("A93:C138").Select
    Selection.Cut
    Range("E47").Select
    ActiveSheet.Paste
    Range("A93:C138").Select
    Selection.Delete Shift:=xlUp

    Range("A139:C184").Select
    Selection.Cut
    Range("E93").Select
    ActiveSheet.Paste
    Range("A139:C184").Select
    Selection.Delete Shift:=xlUp
End Sub

Answer 1

这里有一个模式，因此您可以编写这样的循环：（我可能会有一些增量错误，但要一直尝试直到正确为止。重要的一点是循环语法）。

dim i  as integer
for i  = 2 to 1000000
  i = i + 45
  dim z as integer
  z = i + 45
   Range("A" & i & ":C" & z).Select        ' (I selected 45 rows a time)
    Selection.Cut
    Range("E1").Select             
    ActiveSheet.Paste
    Columns("F:F").ColumnWidth = 15.67
    Range("A" & i & ":C" & z).Select
    Selection.Delete Shift:=xlUp
next i

Answer 2

我想这就是你想要做的。例如，如果您在“ A”列中有1到300个数据，则希望将其拆分为2列，其中“ A”列将包含1到45，而“ E”列将包含46到90。因此总数为165行以覆盖所有300个数据。看起来像这样...

代码将使其如下所示（我已显示3行，但您需要45行）...

Sub make_dual_column()
'speed up's the process
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False


Dim i As Integer, last_row As Integer
'last row of col A
last_row = Range("A" & Rows.Count).End(xlUp).Row
'last row of col E
col_E_last_row = Range("E" & Rows.Count).End(xlUp).Row

'''every after 45 rows, copy the next 45 rows
'''and paste it in column E 
For i = 1 To last_row Step 45
    If i Mod 2 = 0 Then            
        Range("A" & i & ":C" & i + 44).Select
        Selection.Copy
        Range("E" & col_E_last_row & ":G" & col_E_last_row + 44).Select
        ActiveSheet.Paste
        Range("A" & i & ":C" & i + 44).Select
        Selection.ClearContents
        'update the last empty row of column E
        col_E_last_row = Range("E" & Rows.Count).End(xlUp).Row + 1
    End If
Next
    ' delete all empty cells from column A
    Columns("A:A").Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.Delete Shift:=xlUp
    ActiveWorkbook.Save

'back to normal default state
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

如何编写循环以在Excel中复制和粘贴多行？

2 个答案: