VBA Excel -从目录中的所有文件复制一个范围，并粘贴到一个工作簿累积在第一个空行

Question

我使用了一个很好的代码，在这里:

从文件夹内的所有文件复制范围并粘贴到主工作簿

我通过提供:

将粘贴数据从列更改为行

shTarget.Cells(1, lRow).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats

代替:

shTarget.Cells(1, lRow).PasteSpecial xlPasteValuesAndNumberFormats

和to可以正常工作，尽管范围内的所有内容都大致复制到相同的位置。我希望在先前复制的数据下面的第一个空行复制新数据(从目录中的第一个工作簿)。

我试着用下面的例子修改代码:

https://www.mrexcel.com/board/threads/vba-paste-new-data-after-last-row.951096/

https://www.exceldemy.com/excel-vba-copy-paste-values-next-empty-row/

复制并粘贴到下一个空行

通过提供如下偏移量

shTarget.Cells(1, lRow).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats

，但它没有像预期的那样工作。数据仍然被多次复制到相同的位置。最后，我在目录中只有上一个工作簿中的数据。

我的完整代码是这样的:

Sub CopyData(ByRef shSource As Worksheet, shTarget As Worksheet)
Const Bo As String = "A2:H100"
Dim lRow As Long
lRow = shTarget.Cells(Rows.Count, "A").End(xlUp).Row + 1
shSource.Range(Bo).Copy
shTarget.Cells(1, lRow).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = xlCopy
End Sub

如果我改变

lRow = shTarget.Cells(Rows.Count, "A").End(xlUp).Row + 1

lRow = shTarget.Cells(Rows.Count, "A").End(xlUp).Offset(1)

，然后我有一个错误:应用程序定义或对象定义错误

有没有办法按累加方式复制数据?即从第一个工作簿的数据，不管提供的范围(A2:A100)占用范围仅A2:A10和连续的数据从第二个工作簿复制到范围A11:A30，等等?

Answer 1

使用方法复制数据

一个快速修复:使用End属性(不推荐)

Sub CopyDataQF(ByVal shSource As Worksheet, ByVal shTarget As Worksheet)
Const Bo As String = "A2:H100"
Dim FirstRow As Long
FirstRow = shTarget.Cells(shTarget.Rows.Count, "A").End(xlUp).Row + 1
shSource.Range(Bo).Copy
shTarget.Cells(FirstRow, "A").PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End Sub

改进:使用Find方法

Sub CopyData(ByVal shSource As Worksheet, ByVal shTarget As Worksheet)

' Define constants.
Const SRC_RANGE As String = "A2:H100"
Const TGT_FIRST_CELL As String = "A2"

' Reference the Source range.
Dim srg As Range: Set srg = shSource.Range(SRC_RANGE)

' Reference the given first Target cell.
If shTarget.FilterMode Then shTarget.ShowAllData
Dim tfCell As Range: Set tfCell = shTarget.Range(TGT_FIRST_CELL)

' Reference the first available Target cell, the cell in the same column
' but in the row below the bottom-most non-empty row.
With tfCell
Dim tlCell As Range
Set tlCell = .Resize(shTarget.Rows.Count - .Row + 1, _
shTarget.Columns.Count - .Column + 1) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If Not tlCell Is Nothing Then
Set tfCell = shTarget.Cells(tlCell.Row + 1, tfCell.Column)
End If
End With

' Copy.
srg.Copy
tfCell.PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False

End Sub