Question

我正在尝试从工作簿中的每个工作表中复制特定数据，然后将其粘贴到不同的工作表上。每张纸上的行数不同，因此我只需要选择非空白单元格（并排除导致空白的公式，即=＆＃34;＆＃34;）。我还需要它跳过超过5张，因为这些没有要求的信息。表格[＆＃34;摘要模板＆＃34;，＆＃34;里程摘要＆＃34;，＆＃34;里程跟踪器＆＃34;，＆＃34;活动跟踪器＆＃34;和＆＃34; PBI数据＆＃ 34]

以下是我想做的事情：

循环浏览除上述5之外的每个工作表。在每个工作表上，复制范围内的所有非空白单元格（B26：E38）并将其粘贴到＆＃34;活动数据＆＃34;在下一个空白单元格下面。

我试图将几个不同的代码拼凑在一起，但它们都没有一起工作。

请帮忙！

非常感谢任何帮助，谢谢!!

这就是我所拥有的，它在我在活动表上运行时有效，但是当我尝试在所有工作表上运行它时（对于Worksheets中的每个w），我得到了一堆错误。

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

但是，您无法在不同的工作表上复制多个范围（您需要为每个工作表复制/粘贴它）。复杂的选择（不能以这种方式复制）也会出错[/ p>]

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

将数据仅复制到新工作表但循环遍历每个工作表

2 个答案: