在标题和最后一行之间复制行

Question

我发现并修改了一个运行良好的代码，但我在 Set CopyRng = sh.Range("A11:AI15") 上苦苦挣扎。我想要做的是创建一个动态范围，该范围将从每个工作表的 first 表中复制值，该表在名为 Language 的标题和名为 Total。某些单元格在表格中合并（默认模板），表格中有空列（因此 .CurrentRegion 不起作用）。

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
                        After:=sh.Range("A1"), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
On Error GoTo 0
End Function

Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
                        After:=sh.Range("A1"), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column
On Error GoTo 0
End Function
Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

Set DestSh = ActiveWorkbook.Worksheets("test")

' Loop through all worksheets and copy the data to the
' summary worksheet.
For Each sh In ActiveWorkbook.Worksheets
    If sh.Name Like "test*" Then

        Last = LastRow(DestSh)

        ' Specify the range to place the data.
        Set CopyRng = sh.Range("A11:AI15")

        CopyRng.Copy
        With DestSh.Cells(Last + 1, "A")
            .PasteSpecial
            Application.CutCopyMode = False
        End With

        DestSh.Cells(Last + 1, "A").Resize(CopyRng.Rows.Count).Value = sh.Range("F8")
        DestSh.Cells(Last + 1, "AK").Resize(CopyRng.Rows.Count).Formula = "=AG10*3%"
        DestSh.Cells(Last + 1, "AL").Resize(CopyRng.Rows.Count).Formula = "=AG10+AK10"

    End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

DestSh.Columns.AutoFit

With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With

End Sub

问候，

Answer 1

这是一个返回范围的函数。参数说明：

• oW = 您要从中获取范围的工作表

• sStartColHeader = 包含您想要开始范围的标题列的名称（即在您的示例中，这将是“Language”）
  

  Function GetRange(ByVal oW As Worksheet, ByVal sStartColHeader As String) As Range
      Dim oTotRng As Range: Set oTotRng = oW.Cells.Find("total", oW.Cells(1, 1), xlValues, xlPart, xlByRows, xlNext, False, , False)
      Dim oLan As Range
  
      Set oLan = oW.Cells.Find(sStartColHeader, oW.Cells(1, 1), xlValues, xlPart, xlByRows, xlNext, False, , False)
      If oLan Is Nothing Then
          Set GetRange = Nothing
      Else
          Set GetRange = Range(oLan.Offset(1, 0), oTotRng.Offset(0, 1))
      End If
  
  End Function
  

如何使用此功能：
在CopyRangeFromMultiWorksheets 函数中，将Set CopyRng = sh.Range("A11:AI15") 更改为Set CopyRng = GetRange(sh, "Language")。然后有一个If 条件来检查是否返回了一个范围。例如：

Set CopyRng = GetRange(sh, "Language")
If CopyRng Is Nothing Then
    ' your exception code here as range was not returned
Else
    ' rest of your code here as a range was returned
End If

注意：假设工作表中的实际总金额位于包含文本 Total 的单元格右侧的单元格中。因此，如果“H10”有文本Total，则实际总数保存在单元格“I10”中

Answer 2

我找到了一个很好的解决方案。请看下面的代码：

Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
Dim findrow As Long, findrow2 As Long

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

Set DestSh = ThisWorkbook.Worksheets("Summary")


For Each sh In ActiveWorkbook.Worksheets
    If sh.Name <> DestSh.Name Then

        Last = LastRow(DestSh)
        'this method doesn't work with merged cells thhat is why I have to unmerge them first.
        sh.Range("B10:B200").UnMerge
        findrow = sh.Range("B:B").Find("Language Pair", sh.Range("B1")).Row
        findrow2 = sh.Range("B:B").Find("Total", sh.Range("B" & findrow)).Row

        Set CopyRng = sh.Range("A" & findrow + 1 & ":AJ" & findrow2 - 1)

        CopyRng.Copy
        With DestSh.Cells(Last + 1, "B")
            .PasteSpecial
            Application.CutCopyMode = False
        End With

        DestSh.Cells(Last + 1, "A").Resize(CopyRng.Rows.Count).Value = sh.Range("F8")
        DestSh.Cells(Last + 1, "AK").Resize(CopyRng.Rows.Count).Formula = "=AG10*3%"
        DestSh.Cells(Last + 1, "AL").Resize(CopyRng.Rows.Count).Formula = "=AG10+AK10"

    End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

DestSh.Columns.AutoFit

With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With
End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
                        After:=sh.Range("A1"), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
On Error GoTo 0
End Function

Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
                        After:=sh.Range("A1"), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column
On Error GoTo 0
End Function