mehrere Arbeitsblätter zusammenkopieren

Sub neut() For i = 1 To Sheets.Count + 1 If i > Sheets.Count Then Set NewSheet = Worksheets.Add NewSheet.Name = "test" End If If Sheets(i).Name = "test" Then MsgBox "Tabellenblatt Auswertung ist bereits vorhanden!" Exit For End If Next i Set ws1 = Worksheets("test") anz1 = ws1.Cells(65356, 1).End(xlUp).Row ws1.Range("c7:e" & anz1).ClearContents For i = 2 To Sheets.Count 'ab 2.Arbeitsblatt If Sheets(i).Name "test" Then anz1 = ws1.Cells(65356, 1).End(xlUp).Row Set ws2 = Worksheets(Sheets(i).Name) anz2 = ws2.Cells(65356, 1).End(xlUp).Row ws2.Range("c6:e" & anz2).Copy Destination:=ws1.Range("a" & anz1 + 1) End If Next i End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Ufff ... das scheint momentan eine Krankheit zu sein. Diese Art einen Code zu schreiben/zu gestalten habe ich jetzt schon mehrfach in Foren gesehen und immer kommen damit Leute die keine Ahnung von VBA haben und bitten dann den Code richtig zu machen. :(
Das ist nichts gegen Dich, sondern ich rege mich gerade nur ein Wenig darüber auf wie man solch einen schlechten/miesen Code überhaupt jemanden zu kommen lassen kann.
Part One: Den Code schmeisst Du daher am Besten gleich weg. Hier jibbet genug gute Leute die Ahnung von VBA haben und Dir auch problemlos für Dein Problem einen vernünftigen Code schreiben, aber nur extrem wenige die die Lust verspüren solch einen miesen Code lauffähig zu machen ... das ist nämlich schwerer/aufwändiger als den Code gleich vernünftig neu zu schreiben.
Part Two: Wenn derjenige Dir nochmal einen Code zu kommen lässt, spare Dir das kopieren in den Editor und trete ihn gleich in die Tonne.
Sorry, das ich mir gerade so ausdrücklich Luft mache, aber wie gesagt derzeit grasiert solche Codes in einigen Foren/Threads und der Stil (oder besser Nicht-Stil) lässt auf einen oder ein paar wenige Täter die ihr Unwesen treiben schliessen. ^^
Ich denke der nachfolgende Code sollte Dich weiter bringen:


Sub CheckTest()
Dim intZähler As Integer
Dim wksQuelle As Worksheet, wksZiel As Worksheet
On Error GoTo Err_CheckTest
Set wksZiel = ThisWorkbook.Sheets("Test")
' jede Tabelle ausser Index 1 und "Test" abarbeiten
For Each wksQuelle In ThisWorkbook.Worksheets
If wksQuelle.Index  1 And wksQuelle.Name  "Test" Then
' Übertrag beginnt ab Zeile 6 und geht maximal bis Zeile 60
For intZähler = 6 To 60
' nur übertragen wenn E einen Wert beinhaltet, Zeile ohne Inhalt
' in E nicht übertragen
If wksQuelle.Cells(intZähler, 5).Value > "" Then
' Übertragung kann zeilenweise erfolgen
wksQuelle.Rows(intZähler).Copy Destination:= _
wksZiel.Rows(wksZiel.Range("B65500").End(xlUp).Row + 1)
End If
Next intZähler
End If
Next wksQuelle
Exit_CheckTest:
Exit Sub
Err_CheckTest:
Select Case Err.Number
Case 9
' tritt auf bei der Set-Anweisung wenn das Sheet "Test" nicht existiert
' Behandlung: neues Sheet mit dem Namen "Test" anlegen und an gleicher
' Stelle weitermachen
ThisWorkbook.Worksheets.Add
ActiveSheet.Name = "Test"
ActiveSheet.Range("B5").Value = "Übertrag zum Auswerten:"
Resume
Case Else
' alle anderen Fehler
MsgBox Err.Number & " " & Err.Description
End Select
Resume Exit_CheckTest
End Sub

Gib mal Bescheid ob's geholfen hat. ;)
Gruß
Rainer

Sub CheckTest() Dim intZähler As Integer Dim wksQuelle As Worksheet, wksZiel As Worksheet On Error GoTo Err_CheckTest Set wksZiel = ThisWorkbook.Sheets("Test") ' jede Tabelle ausser Index 1 und "Test" abarbeiten For Each wksQuelle In ThisWorkbook.Worksheets If wksQuelle.Index 1 And wksQuelle.Name "Test" Then ' Übertrag beginnt ab Zeile 6 und geht maximal bis Zeile 60 For intZähler = 6 To 60 ' nur übertragen wenn E einen Wert beinhaltet, Zeile ohne Inhalt ' in E nicht übertragen If wksQuelle.Cells(intZähler, 5).Value > "" Then ' Übertragung kann zeilenweise erfolgen wksQuelle.Rows(intZähler).Copy Destination:= _ wksZiel.Rows(wksZiel.Range("B65500").End(xlUp).Row + 1) End If Next intZähler End If Next wksQuelle Exit_CheckTest: Set wksZiel = Nothing Set wksQuelle = Nothing Exit Sub Err_CheckTest: Select Case Err.Number Case 9 ' tritt auf bei der Set-Anweisung wenn das Sheet "Test" nicht existiert ' Behandlung: neues Sheet mit dem Namen "Test" anlegen und an gleicher ' Stelle weitermachen ThisWorkbook.Worksheets.Add With ActiveSheet .Name = "Test" .Range("B5").Value = "Übertrag zum Auswerten:" End With Resume Case Else ' alle anderen Fehler MsgBox Err.Number & " " & Err.Description End Select Resume Exit_CheckTest End Sub

Sub CheckTest() Dim intZähler As Integer Dim wksQuelle As Worksheet, wksZiel As Worksheet On Error GoTo Err_CheckTest Set wksZiel = ThisWorkbook.Sheets("Test") ' Zielbereich reinigen For intZähler = 6 To wksZiel.UsedRange.Rows.Count + 6 wksZiel.Rows(intZähler).ClearContents Next intZähler ' jede Tabelle ausser Index 1 und "Test" abarbeiten For Each wksQuelle In ThisWorkbook.Worksheets If wksQuelle.Index 1 And wksQuelle.Name "Test" Then ' Übertrag beginnt ab Zeile 6 und geht maximal bis Zeile 60 For intZähler = 6 To 60 ' nur übertragen wenn E einen Wert beinhaltet, Zeile ohne Inhalt ' in E nicht übertragen If wksQuelle.Cells(intZähler, 5).Value > "" Then ' Übertragung kann zeilenweise erfolgen wksQuelle.Rows(intZähler).Copy ' Eintrag erst ab Zeile 6 vornehmen und nur Inhalte aber keine Formate kopieren If wksZiel.Range("B6").Value = "" Then wksZiel.Rows(6).PasteSpecial xlValues Else wksZiel.Rows(wksZiel.Range("B65500").End(xlUp).Row + 1).PasteSpecial xlValues End If Application.CutCopyMode = False End If Next intZähler End If Next wksQuelle Exit_CheckTest: Set wksZiel = Nothing Set wksQuelle = Nothing Exit Sub Err_CheckTest: Select Case Err.Number Case 9 ' tritt auf bei der Set-Anweisung wenn das Sheet "Test" nicht existiert ' Behandlung: neues Sheet mit dem Namen "Test" anlegen und an gleicher ' Stelle weitermachen ThisWorkbook.Worksheets.Add With ActiveSheet .Name = "Test" End With Resume Case Else ' alle anderen Fehler MsgBox Err.Number & " " & Err.Description End Select Resume Exit_CheckTest End Sub

Hallo
Das Makro ist eigentlich untauglich, weil diese Schleife sinnlos ist.
For i = 1 To Sheets.Count + 1
If i > Sheets.Count Then
Set NewSheet = Worksheets.Add
NewSheet.Name = "test"
End If
If Sheets(i).Name = "test" Then
MsgBox "Tabellenblatt Auswertung ist bereits vorhanden!"
Exit For
End If
Next i
"i" wird IMMER grösser sein als "Sheets.Count" und die "If Sheets(i).Name " funktioniert nur solange die Tabelle ZUFÄLLIG in der Reihenfolge kommt. Weil die Tabelle aber immer zum Schluss angefügt wird, kommt es entweder zu einem Fehler oder du erhältst immer wieder neue Tabellen.
Das Makro kopiert nicht ab B1 sondern ab C6.
Ein klein wenig lesen und nachdenken,... schon geht es.
Ändere die Zeile
ws2.Range("c6:e" & anz2).Copy Destination:=ws1.Range("a" & anz1 + 1)
und passe den Bezug entsprechend an
ws2.Range("B6:e" & anz2).Copy Destination:=ws1.Range("a" & anz1 + 1)
Hier eine Alternative mit Variablendeklaration

Option Explicit

Sub neut()
    Dim i As Long, Qe As Long, tarRow As Long, rowToCopy As Long
    Dim shExist As Boolean
    Dim wks1 As Worksheet
    For i = 1 To Sheets.Count
        If UCase(Worksheets(i).Name) = "TEST" Then
            Qe = MsgBox("Tabellenblatt Auswertung ist bereits vorhanden!" & vbCrLf & "Möchten Sie den Inhalt löschen und die Tabelle neu erstellen ?", vbCritical + vbYesNo, "ACHTUNG")
            If Qe = vbNo Then
                MsgBox "Makro zur Auswertung abgebrochen", vbCritical + vbOKOnly, "Abbruch"
                Exit Sub
            Else
                Set wks1 = Worksheets(i)
                wks1.Cells.ClearContents
                shExist = True
                Exit For
            End If
        End If
    Next i
    If shExist = False Then
        Set wks1 = Worksheets.Add
        wks1.Name = "TEST"
    End If
    '*********************
    'oder dies als quick and dirty alternative ohne Schleife
    'Kommentarzeichen entfernen
    '
    'On Error Resume Next
    'Set wks1 = Worksheets("Test")
    'If wks1 Is Nothing Then
    ' Set wks1 = Worksheets.Add
    ' wks1.Name = "Test"
    'End If
    'wks1.Cells.ClearContents
    'On Error GoTo 0
    '
    'Alternative Ende
    '****************
    For i = 1 To Sheets.Count
        If UCase(Sheets(i).Name) <> "TEST" Then
            tarRow = wks1.Cells(Rows.Count, 1).End(xlUp).Row + 1
            With Worksheets(i)
                rowToCopy = .Cells(Rows.Count, 1).End(xlUp).Row
                'Bereich der kopiert werden soll
                .Range("B6:E" & rowToCopy).Copy Destination:=wks1.Range("A" & tarRow)
            End With
        End If
    Next i
    Set wks1 = Nothing
    MsgBox "Alle Tabellen kopiert", vbInformation + vbOKOnly, "Fertig"
End Sub

Gruss Rainer

Beliebteste Forumthreads (12 Monate)

mehrere Arbeitsblätter zusammenkopieren

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

mehrere Arbeitsblätter zusammenkopieren

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread