Question

我发现并修改了一个效果很好的代码，但我正在努力使用Set CopyRng = sh.Range("A11:AI15")。我想要做的是创建一个动态范围，该范围将从名为 Language 的标题和名为 Total <的表中的最后一行之间的每个工作表中的第一表中复制值/ em>的。一些单元格在表中合并（默认模板），表格中有空列（因此.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 =保存要从其开始范围的标题列的名称（例如，在您的示例中，这将是“语言”）
< / p>

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

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

2 个答案: