在所需的位置粘贴来自多个工作表的数据

这是我用来从多个工作表复制数据到单个工作表的代码。 我想知道是否有任何方法可以将数据复制到从第三列开始的“报告”表格中，即将数据从第三列开始粘贴到表格中。

Sub AppendDataAfterLastColumn() Dim sh As Worksheet Dim DestSh As Worksheet Dim Last As Variant Dim CopyRng As Range With Application .ScreenUpdating = False .EnableEvents = False End With ' Delete the summary worksheet if it exists. Application.DisplayAlerts = False On Error Resume Next ActiveWorkbook.Worksheets("Report").Delete On Error GoTo 0 Application.DisplayAlerts = True ' Add a worksheet with the name "Report" Set DestSh = ActiveWorkbook.Worksheets.Add DestSh.Name = "Report" ' Loop through all worksheets and copy the data to the ' summary worksheet. For Each sh In ActiveWorkbook.Worksheets If sh.Name <> DestSh.Name Then lastcol = DestSh.Cells(1, DestSh.Columns.Count).End(xlToLeft).Column ' Find the last column with data on the summary ' worksheet. Last = lastcol lastCol3 = sh.Cells(1, sh.Columns.Count).End(xlToLeft).Column ' Fill in the columns that you want to copy. Set CopyRng = sh.Range(sh.Cells(1, 2), sh.Cells(15, lastCol3)) ' Test to see whether there enough rows in the summary ' worksheet to copy all the data. If Last + CopyRng.Columns.Count > DestSh.Columns.Count Then MsgBox "There are not enough columns in " & _ "the summary worksheet." GoTo ExitTheSub End If ' This statement copies values, formats, and the column width. CopyRng.Copy With DestSh.Cells(1, Last + 1) .PasteSpecial 8 ' Column width .PasteSpecial xlPasteValues '.PasteSpecial xlPasteFormats Application.CutCopyMode = False End With End If Next ExitTheSub: Application.Goto DestSh.Cells(1) With Application .ScreenUpdating = True .EnableEvents = True End With End Sub 

数据表1来自评论：

数据表2来自评论：

预期的评论输出：

Answer 1

这种复制可以通过复制轻松完成。 为了select粘贴部分的输出Range ，可以使用带有Type:=8参数的Application.InputBox 。 这提示Excel打开Rangeselect对话框，效果很好。

一旦你知道这两件事，唯一的困难是build立Ranges 。 这并不困难，但是特定于上下文，表格上的现有数据以及坚固程度。 对于下面的示例，我使用CurrentRegion获取数据块（与按CTRL + A相同），然后Intersect以仅获取所需的列。 您也可以使用UsedRange和End来构build范围。

范围图片显示了不同的input页面和输出的最终页面。 现在粘贴到c的表格是空的。

代码做的工作，以获得两个范围复制，然后提示输出位置。 从那里，它将产生的Ranges粘贴到所需的位置。 有一个Offset以确保第二范围不重叠的第一个。

 Sub CopyFromTwoRanges() Dim rng_set1 As Range Dim rng_set2 As Range Dim rng_output As Range 'build the ranges Set rng_set1 = Intersect(Sheets("a").Range("C:F"), _ Sheets("a").Range("C1").CurrentRegion) Set rng_set2 = Intersect(Sheets("b").Range("C:F"), _ Sheets("b").Range("C1").CurrentRegion) 'prompt for cell Set rng_output = Application.InputBox("Pick the range", Type:=8) 'ensure a single cell only Set rng_output = rng_output.Cells(1, 1) 'paste the ranges rng_set1.Copy rng_output rng_set2.Copy rng_output.Offset(, rng_set1.Columns.Count) End Sub 

结果显示提示单元格select，然后输出。