将多个工作簿中的两个范围（单个单元格和范围）组合到工作表中答案

【问题标题】：combine two ranges (single cell and range) from multiple workbooks to worksheet将多个工作簿中的两个范围（单个单元格和范围）组合到工作表中
【发布时间】：2017-06-29 20:26:02
【问题描述】：

我在这里有一些脚本来打开带有工作表的多个工作簿，然后将其作为循环复制到工作表中，但是我需要来自多个工作簿中另一个工作表的附加单元格（日期），因为我得到的输出不能更改并添加到同一张工作表中。

我需要此代码包含工作簿上另一个工作表中的单个单元格范围，然后将其填充到每个工作簿范围的底部。

我不能使用UNION，因为它的长度不同，我查找了将范围合并为一个，但出现类型不匹配错误。

VBA: How to combine two ranges on different sheets into one, to loop through我试过这个，但我不知道如何将它放入我的代码中。

这是我目前仅适用于一个范围的代码。 rngdate 复制过来，但不会留下间隙或自动填充到下一个循环，它只是相互粘贴，所以也许这段代码可以工作，但我缺少一些基本的东西，比如自动填充？

Dim vFileNames As Variant
Dim y As Long
Dim wbTemp As Workbook
Dim wbNew As Workbook
Dim blHeader As Boolean
Dim Rng As Range
Dim rngDate As Range

Application.ScreenUpdating = False
Set wbNew = Workbooks("master_timesheet") '.Add
blHeader = False
vFileNames = Application.GetOpenFilename(Title:="Select all workbooks to copy", _
MultiSelect:=True)
 'Will not be array if no file is selected
 'If user selects one or more files, files will be stored as an array
If Not IsArray(vFileNames) Then GoTo ConsolidateWB_End
For y = LBound(vFileNames) To UBound(vFileNames)
     'Open each wb selected
    Set wbTemp = Workbooks.Open(vFileNames(y))
    Set rngDate = wbTemp.Worksheets("Communications Unlimited Inc").Range("A5").CurrentRegion
    Set Rng = wbTemp.Worksheets("Export").Range("A1").CurrentRegion


     'If header row already copied, then offset by 1 to exclude header
    If blHeader Then
        Set Rng = Rng.Offset(1, 0).Resize(Rng.Rows.Count - 1)
         'If header row not already copied, keep rng as is and change blHeader to true
    Else
        blHeader = True
    End If
     'Paste to next row on new wb

    Rng.Copy Destination:=wbNew.Sheets(1).Range("A65536").End(xlUp).Offset(1, 0)
    rngDate.Copy Destination:=wbNew.Sheets(1).Range("P65536").End(xlUp).Offset(1, 0)

    wbTemp.Close SaveChanges:=False
Next y
    ConsolidateWB_End:
        Application.ScreenUpdating = True
End Sub

【问题讨论】：

标签： vba excel

【解决方案1】：

如果我正确阅读了您的问题，您希望将日期 rngdate 粘贴到您刚刚复制的每一行数据旁边。但是，您当前的代码仅将数据放在第一行。考虑到您现有的代码，下面是我自己解决这个问题的改编。（我的猜测是有一个比这更优雅的解决方案，我只是不知道。）

Dim pasterangefirstrow As Integer

...

pasterangefirstrow = wbNew.Sheets(1).Range("D65536").End(xlUp).Offset(1, 0).Row

...

With wbNewSheets(1)
    Rng.Copy Destination:=.Range("D65536").End(xlUp).Offset(1, 0)
    rngdate.Copy Destination:=.Range("P" & pasterangefirstrow & ":P" & pasterangefirstrow + Rng.Rows.Count - 1)
End With

【讨论】：