複製標題和最後一行之間的行

Question

我發現並修改了一個工作得很好的代碼，但我正在努力與Set CopyRng = sh.Range("A11:AI15")。我想要做的是創建一個動態範圍將從第一表從每個工作表稱爲語言頭和最後一行之間的表複製值稱爲總。有些單元格在表格中合併（默認模板），表格中有空列（所以.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

我發現的偉大工程的解決方案。看到下面的代碼：

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 

Answer 2

這裏是一個將返回範圍內的功能。參數說明：

• oW =你想從

• sStartColHeader得到的範圍內的工作表=保持要開始從範圍標題列的名稱（即在您的例子，這將是「語言「）
  

  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」