使用动态范围进行条件数据提取

Question

我必须根据单元格名称与工作表名称匹配从多个列中复制数据范围。但是，在某些匹配的工作表名称的情况下，我们有 30 个数据，在某些情况下，我们可能有 20 个数据或任何其他值，“A”列中每个 ID 的数据范围是不同的。我当前的代码使我能够从“组合”工作表中提取数据到具有匹配工作表名称的模板工作表。我如何使代码动态并根据 A 列中更改的工作表名称提取数据，而不是使用匹配范围的偏移量提取 30 个数据（每个钻孔名称之后有一些空白单元格，直到“A”列中的下一个名称需要考虑用于开发 VBA 代码）并从 M 和 S 列复制与该名称对应的数据，并根据匹配的工作表名称粘贴到 E 和 G 列的模板工作表中。目前我只能从一列中提取数据，代码需要动态更新：

Sub SPT()
Dim wkSht As Worksheet
Dim cell As Range

For Each cell In Sheets("Combine").Range("A5:A116").Cells

    For Each wkSht In ThisWorkbook.Worksheets
    
        If cell.Value = wkSht.Name Then
       
            Sheets("Combine").Range(cell.Offset(0, 12), cell.Offset(29, 12)).Copy wkSht.Range("G22")
        End If
    
    Next wkSht

Next cell
End Sub

Answer 1

复制粘贴过程会根​​据Col H中的单元格值偏移，请测试运行，谢谢：

Sub SPT()
Dim wkSht As Worksheet
Dim cell As Range
Dim lastrow As Long, blankRow As Long, offsetRow As Long

lastrow = Sheets("Combine").UsedRange.Rows.Count

For Each cell In Sheets("Combine").Range("A2", "A" & lastrow).Cells

    For Each wkSht In ThisWorkbook.Worksheets
    
        If cell.Value = wkSht.Name Then
        
            If cell.End(xlDown).Row > lastrow Then
                blankRow = lastrow
            Else
                blankRow = cell.End(xlDown).Row - 1
            End If
            
            offsetRow = Application.WorksheetFunction.RoundDown(Sheet1.Cells(blankRow, 8).Value, 0)
            Sheets("Combine").Range(cell.Offset(0, 12), cell.Offset(offsetRow, 12)).Copy wkSht.Range("G22")
            Sheets("Combine").Range(cell.Offset(0, 18), cell.Offset(offsetRow, 18)).Copy wkSht.Range("E22")
        End If
    
    Next wkSht

Next cell
End Sub

假设您在Col A 中的最后一个工作表名称是第 14 行，下面是空白数据

当你使用键盘快捷键ctrl + down arrow key时，它会跳转到第100万行，因为我知道这种情况会发生但我不想获得row 1mil，因此我将设置blankRow = lastrow(i.e. 20)