Kopieren Sie nur Datenzellen in ein neues Arbeitsblatt, aber durchlaufen Sie jedes Arbeitsblatt.

Question

Ich versuche, bestimmte Daten von jedem Blatt in einer Arbeitsmappe zu kopieren und sie nacheinander auf ein anderes Blatt einzufügen. Die Anzahl der Zeilen ist auf jedem Blatt unterschiedlich, daher muss ich nur nicht leere Zellen auswählen (und Formeln ausschließen, die zu Leerzeichen führen, dh = ""). Ich brauche es auch, um über 5 Blätter zu überspringen, da diese die Informationen nicht angefordert haben. Sheets [ "ZUSAMMENFASSUNG TEMPLATE", "Kontoauszug", "MILEAGE TRACKER", "ACTIVITY TRACKER" und "PBI DATA"]

Hier ist, was ich tun möchte:

• Schleife durch jedes Arbeitsblatt außer den 5 oben. Kopieren Sie auf jedes Arbeitsblatt alle nicht leeren Zellen im Bereich (B26: E38) und fügen Sie sie in das Blatt "Aktivitätsdaten" unter der nächsten leeren Zelle ein.

Ich habe versucht, ein paar verschiedene Codes zusammenzufügen, aber keiner von ihnen funktioniert zusammen.

Bitte helfen!

Ich schätze wirklich jede Hilfe, danke !!

Hier ist, was ich habe, es funktioniert, wenn ich es auf dem Active Sheet ausführen, aber wenn ich es auf allen Blättern (für jedes ws in Worksheets) ausführen, bekomme ich eine Reihe von Fehlern.

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

pls versuchen, diesen Code (Code hat zu viele End If, End With und 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 

noch, Sie mehrere Bereiche über verschiedene Arbeitsblätter nicht kopiert werden können (Sie müssen es kopieren/einfügen für jedes Blatt). Es wird auch Fehler für komplexe Selektionen (die nicht auf diese Weise kopiert werden können)

Answer 2

Ist das, was Sie versuchen? Wenn ja, dann lass es mich wissen und ich werde den Code kommentieren.

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