仅将数据复制到新工作表的单元格，但循环遍历每个工作表

Question

我试图从工作簿中的每个工作表中复制特定数据，并将其粘贴到另一个工作表上。每行的行数是不同的，所以我只需要选择非空白单元格（并排除导致空白的公式即=“”）。我还需要它跳过5张纸，因为这些纸张没有要求的信息。表[“汇总模板”，“的里程”，“里程监测”，“行为跟踪”和“PBI DATA”]

这里是我想要做什么：

• 遍历除上述5以外的每个工作表。 在每个工作表上复制范围内的所有非空白单元格（B26：E38），并将它们粘贴到下一个空白单元格下的“活动数据”表单上。

我试图拼凑一些不同的代码，但他们没有一起工作。

请帮忙！

我非常感谢任何帮助，谢谢！

这是我有，它运作时，我运行它在activesheet，但是当我尝试运行它在所有表（对于工作表中的每个ws）我得到一堆错误。

Sub a() 
    Dim LR As Long, cell As Range, rng As Range 
    Dim ws As Worksheets 



    For Each ws In Worksheets 
     With ws 
     LR = ws.Range("B" & Rows.Count).End(xlUp).row 

     If ws.Name <> "SUMMARY TEMPLATE" And ws.Name <> "MILEAGE SUMMARY" And ws.Name <> "MILEAGE TRACKER" _ 
    And ws.Name <> "ACTIVITY TRACKER" And ws.Name <> "PBI DATA" Then 
    For Each cell In .Range("B26:E26" & LR) 
    If cell.Value <> "" Then 
     If rng Is Nothing Then 
      Set rng = cell 
     Else 
      Set rng = Union(rng, cell) 
     End If 
    End If 
Next cell 
rng.Select 
End With 
Next ws 
End If 
End With 
Next 
Selection.Copy 
Sheets("ACTIVITY TRACKER").Select 
Range("A" & Rows.Count).End(xlUp).Offset(1).Select 
Selection.PasteSpecial Paste:=xlPasteValues 
End Sub 

Answer 1

请试试这个代码（代码有许多End If，End With和Next）：

Sub a() 
    Dim LR As Long, cell As Range, rng As Range 
    Dim ws As Worksheet 
    For Each ws In Worksheets 
    With ws 
     If .Name <> "SUMMARY TEMPLATE" And .Name <> "MILEAGE SUMMARY" And .Name <> "MILEAGE TRACKER" _ 
              And .Name <> "ACTIVITY TRACKER" And .Name <> "PBI DATA" Then 
     LR = .Range("B" & Rows.Count).End(xlUp).Row 
     For Each cell In .Range("B26:E" & LR) 
      If cell.Value <> "" Then 
      If rng Is Nothing Then 
       Set rng = cell 
      Else 
       Set rng = Union(rng, cell) 
      End If 
      End If 
     Next cell 
     If Not rng Is Nothing Then 
      rng.Copy 
      Sheets("ACTIVITY TRACKER").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues 
      Set rng = Nothing 
     End If 
     End If 
    End With 
    Next ws 
End Sub 

的是，你不能在不同的工作表复制多个范围（你需要复制/粘贴为每张纸）。它也会出错复杂的选择（不能以这种方式复制）

Answer 2

这是你正在尝试？如果是，那么让我知道，我会评论这些代码。

Option Explicit 

Dim ws As Worksheet, wsOutput As Worksheet 
Dim lRow As Long 

Sub Sample() 
    Dim rngToCopy As Range, aCell As Range 
    Dim Myar As Variant, Ar 

    Set wsOutput = ThisWorkbook.Sheets("Activity Data") 

    For Each ws In ThisWorkbook.Worksheets 
     Select Case UCase(ws.Name) 
     Case UCASE(wsOutput.Name), "SUMMARY TEMPLATE", "MILEAGE SUMMARY", _ 
     "MILEAGE TRACKER", "ACTIVITY TRACKER", "PBI DATA" 
     Case Else 
      lRow = GetLastRow 

      For Each aCell In ws.Range("B26:E38") 
       If aCell.Value <> "" Then 
        If rngToCopy Is Nothing Then 
         Set rngToCopy = aCell 
        Else 
         Set rngToCopy = Union(rngToCopy, aCell) 
        End If 
       End If 
      Next aCell 
     End Select 

     If Not rngToCopy Is Nothing Then 
      For Each Ar In rngToCopy 
       lRow = GetLastRow 
       Ar.Copy wsOutput.Range("A" & lRow) 
      Next Ar 
      Set rngToCopy = Nothing 
     End If 
    Next ws 
End Sub 

Function GetLastRow() As Long 
    With wsOutput 
     If Application.WorksheetFunction.CountA(.Cells) <> 0 Then 
      lRow = .Cells.Find(What:="*", _ 
          After:=.Range("A1"), _ 
          Lookat:=xlPart, _ 
          LookIn:=xlFormulas, _ 
          SearchOrder:=xlByRows, _ 
          SearchDirection:=xlPrevious, _ 
          MatchCase:=False).Row + 1 
     Else 
      lRow = 1 
     End If 
    End With 

    GetLastRow = lRow 
End Function