如何将数据粘贴到范围的起始行和列在单元格中定义的范围中？

Question

我的 excel 文件中有两张工作表：

输入表： Sheet1

目标表： Sheet2

我想要实现的是将值从我在单元格C5 中定义的列开始粘贴，并从我在单元格C6 中定义的行开始粘贴。如果单元格C5和C6定义的范围已经有数据，那么它将根据单元格C5中的列找到下一个空行并将数据粘贴到该空行中。

例如在上面的屏幕截图中，单元格C5和C6中定义的起始列和行是B8，因此复制的值将从单元格B8开始粘贴，直到E8。但是，如果该行已经有数据，那么它将根据 B 列（即B9）找到下一个空行并将其粘贴到那里。

我不确定如何修改我当前的脚本：

Public Sub CopyData()

    Dim InputSheet As Worksheet ' set data input sheet
    Set InputSheet = ThisWorkbook.Worksheets("Sheet1")
    
    Dim InputRange As Range ' define input range
    Set InputRange = InputSheet.Range("G6:J106")
    
    Dim TargetSheet As Worksheet
    Set TargetSheet = ThisWorkbook.Worksheets("Sheet2")
    
    Const TargetStartCol As Long = 2        ' start pasting in this column in target sheet
    Const PrimaryKeyCol As Long = 1         ' this is the unique primary key in the input range (means first column of B6:G6 is primary key)
    
    Dim InsertRow As Long

    InsertRow = TargetSheet.Cells(TargetSheet.Rows.Count, TargetStartCol + PrimaryKeyCol - 1).End(xlUp).Row + 1
  
    ' copy values to target row
    TargetSheet.Cells(InsertRow, TargetStartCol).Resize(ColumnSize:=InputRange.Columns.Count).Value = InputRange.Value

End Sub

任何帮助或建议将不胜感激！

测试场景 1

测试场景 1 的输出

Answer 1

请尝试下一个代码：

Public Sub CopyData_()
    Dim InputSheet As Worksheet: Set InputSheet = ThisWorkbook.Worksheets("Sheet1")
    Dim InputRange As Range: Set InputRange = InputSheet.Range("G6:J106")
    Dim arr: arr = InputRange.Value
    
    Dim TargetSheet As Worksheet: Set TargetSheet = ThisWorkbook.Worksheets("Sheet2")
    Dim TargetStartCol As String, PrimaryKeyRow As Long
    TargetStartCol = TargetSheet.Range("C5").Value       ' start pasting in this column in target sheet
    PrimaryKeyRow = TargetSheet.Range("C6").Value        ' this is the row after the result to be copied
    
    Dim InsertRow As Long

    InsertRow = TargetSheet.cells(TargetSheet.rows.Count, TargetStartCol).End(xlUp).row + 1
    If InsertRow < PrimaryKeyRow Then InsertRow = PrimaryKeyRow + 1 'in case of no entry after PrimaryKeyRow (neither the label you show: "Row")
    ' copy values to target row
    TargetSheet.cells(InsertRow, TargetStartCol).Resize(UBound(arr), UBound(arr, 2)).Value = arr
End Sub

未经测试，但我认为应该可以。如果有不清楚或出错的地方，请毫不犹豫地提及错误，它对您有什么作用/没有对您的需要或其他任何需要纠正的事情。

Answer 2

将数据复制到另一个工作表

Option Explicit

Sub CopyData()
    
    Const sName As String = "Sheet1"
    Const rgAddress As String = "G6:J106"

    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = wb.Worksheets(sName)
    Dim rg As Range: Set rg = ws.Range(rgAddress)

    WriteCopyData rg

    ' or just:
    'WriteCopyData ThisWorkbook.Worksheets("Sheet1").Range("G6:J106")

End Sub

Sub WriteCopyData(ByVal SourceRange As Range)

    Const dName As String = "Sheet2"
    Const dRowAddress As String = "C6"
    Const dColumnAddress As String = "C5"
    
    Dim rCount As Long: rCount = SourceRange.Rows.Count
    Dim cCount As Long: cCount = SourceRange.Columns.Count
    
    Dim dws As Worksheet
    Set dws = SourceRange.Worksheet.Parent.Worksheets(dName)
    
    Dim dRow As Long: dRow = dws.Range(dRowAddress).Value
    Dim dCol As String: dCol = dws.Range(dColumnAddress).Value

    Dim dfrrg As Range: Set dfrrg = dws.Cells(dRow, dCol).Resize(1, cCount)
    Dim dlCell As Range
    Set dlCell = dfrrg.Resize(dws.Rows.Count - dRow + 1) _
        .Find("*", , xlFormulas, , xlByRows, xlPrevious)
    
    If Not dlCell Is Nothing Then
        Set dfrrg = dfrrg.Offset(dlCell.Row - dRow + 1)
    End If
    
    Dim drg As Range: Set drg = dfrrg.Resize(rCount)
    drg.Value = SourceRange.Value
    
End Sub