复制dynamic范围并粘贴具有重复值的dynamic范围

我想复制和粘贴dynamic范围。 尤其是粘贴复制范围的每个来源的重复值。 这里是我从录制macros创build的代码：

Sub copyRange() Range("A2").Select Range(Selection, Selection.End(xlToRight)).Select Selection.Copy Range("L2:S7").Select ActiveSheet.Paste Range("A3").Select Range(Selection, Selection.End(xlToRight)).Select Application.CutCopyMode = False Selection.Copy Range("L8:S13").Select ActiveSheet.Paste Range("A4").Select Range(Selection, Selection.End(xlToRight)).Select Application.CutCopyMode = False Selection.Copy Range("L14:S19").Select ActiveSheet.Paste Range("A5").Select Range(Selection, Selection.End(xlToRight)).Select Application.CutCopyMode = False Selection.Copy ActiveWindow.SmallScroll Down:=3 Range("L20:S25").Select ActiveSheet.Paste End Sub 

这是我想要的截图输出：

Answer 1

 Sub CopyPasteData() Dim lRw As Long, lRw_2 As Long, x As Long, rActive As Range Set rActive = ActiveCell lRw = Cells(Rows.Count, "A").End(xlUp).Row Application.ScreenUpdating = False Range("K2:R" & Rows.Count).ClearContents For i = 2 To lRw x = x + 1 Range("A" & i & ":H" & i).Copy lRw_2 = Cells(Rows.Count, "K").End(xlUp).Row + 1 With Range("K" & lRw_2).Resize(6) .PasteSpecial xlPasteAll .Offset(, -1).Value = x End With Next i Application.CutCopyMode = False rActive.Select Application.ScreenUpdating = True End Sub