Question

我有一个小问题。我正在尝试编写代码来选择一系列数据，例如A2：[直到最后一行]例如一张纸上的F36，然后复制它，例如另一个工作表中的单元格（1,1）。然后将此范围向右偏移第n个数字（以使该范围不扩大也不更改值，而仅向右移动第n列），然后复制该范围并将其再次粘贴到另一张纸上。另外，我希望将数据插入到先前粘贴的数据的最后一行之后。

该数据集不是由固定数字定义的，因此复制和粘贴数字的操作不是固定的。让它们按某些步骤运行真是太棒了，例如直到最后一个空列。

有人有解决问题的想法吗？

Sub copy()
Dim lastRow As Long
Dim lastCol As Long
' this finds the number of the last row
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
' beginig of the script


  '1st range
    Dim i As Integer, MyRange As Range
For i = 1 To 2
    Sheets("Sheet1").Activate
   ' Range("B8:F27").Select
    Set MyRange = Range("B8:H27").Offset(0, i * 7)
    MyRange.Select
    Selection.copy
    Sheets("Sheet2").Activate
    Cells(lastRow + 1, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks _
   :=False, Transpose:=False
    Cells(lastRow + 1, 1).PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks _
   :=False, Transpose:=False
     Application.CutCopyMode = False


Next i


End Sub

这是我尝试过的。偏移量正常工作。我在复制过程中遇到问题。范围移动正常，但仅将第三步（最后一步）复制到Sheet2。我相信我应该使用第二个循环，但是在这种情况下不知道如何正确地制定它。

Edit2：完成了。

    Sub CopyRanges()
    Dim lastRow As Long
    Dim lastCol As Long
    Dim i As Integer, MyRange As Range, MyNextRange As Range, MyRange1 As Range
    Set MyRange = Range("B8:H27")

        Sheets("Sheet1").Activate
        Range("B7:H7").copy
'this is to copy the header. Can be ommited. 
        Sheets("Sheet2").Activate
        Cells(1, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    'begining of the loop. I have 16 ranges to copy from one sheet to another. The offset is 7 columns 0 rows.
        For i = 0 To 15
            Sheets("Sheet1").Activate
            Set MyRange1 = MyRange.Offset(0, i * 7)
            MyRange1.Select
            Selection.copy
            Sheets("Sheet2").Activate
            lastRow = Cells(Rows.Count, 1).End(xlUp).Row
            Cells(lastRow + 1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Next i
'had some errors with blanks. 
    On Error GoTo Errorcatch

    Dim removeCol As Range
    On Error Resume Next
' here I select all copied ranges & select blank cells. This removes the entire row when found a blank
        For Each removeCol In Range("A2:G700").Columns
            removeCol.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Next removeCol
 ' final operation. Moves the window to row 1    
        ActiveWindow.ScrollRow = 1
      Exit Sub
    Errorcatch:
    MsgBox Err.Description
    End Sub

您怎么看？我可以进行哪些优化？有什么想法吗？

谢谢大家的想法。

VBA-将范围复制到新图纸并将该范围偏移到另一个位置并再次复制

0 个答案: