Live-Forum - Die aktuellen Beiträge
Datum
Titel
19.04.2024 16:34:52
gemeinsamer Filter über drei Spalten
19.04.2024 15:39:42
Exceltabelle daten per combobox zu word Datei
19.04.2024 14:04:05
PDF per VBA ausgeben - Seitenskalierung
19.04.2024 13:58:02
Set Worksheet geht im O365 aber im Excel 2016 nicht
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
944to948
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
944to948
944to948
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Alle sheets Z12-Z26 in eines kopieren

Alle sheets Z12-Z26 in eines kopieren
28.01.2008 19:13:00
Bernhard
Servus,
ich habe eine Jahres Excel mit einem Sheet pro Woche und möchte nun von allen Sheets die Zeilen 3-4 und 12-26 in ein Sheet untereinanander kopieren.
Ich bekomme es mit dem Makrorecorder einfach nicht hin. Aber das geht doch irgendwie. Brauche ich da VB? Nur damit kenne ich mich nicht aus.
Danke für eure Hilfe.
Bernhard

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Alle sheets Z12-Z26 in eines kopieren
29.01.2008 00:23:00
Josef
Hallo Bernhard,
VB brauchst du dazu nicht, aber VBA und das ist genau das, was der Rekorder aufzeichnet.
Ohne nähere Angaben, probier mal diesen Code.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub copyLines()
Dim objWs As Worksheet, objNewWs As Worksheet

With ThisWorkbook
    On Error Resume Next
    Set objNewWs = .Sheets("Zusammenfassung")
    On Error GoTo 0
    
    On Error GoTo ErrExit
    GMS
    
    If objNewWs Is Nothing Then
        Set objNewWs = .Worksheets.Add(Before:=.Sheets(.Sheets.Count))
        objNewWs.Name = "Zusammenfassung"
    End If
    
    For Each objWs In .Worksheets
        objWs.Rows("3:4").Copy objNewWs.Rows(objNewWs.Cells(Rows.Count, 1).End(xlUp).Row)
        objWs.Rows("12:26").Copy objNewWs.Rows(objNewWs.Cells(Rows.Count, 1).End(xlUp).Row)
    Next
    
End With

ErrExit:
If Err.Number > 0 Then
    MsgBox Err.Number & vbLf & Err.Description
End If
GMS True
Set objWs = Nothing
Set objNewWs = Nothing
End Sub

Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long

With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Modus Then
        .Calculation = IIf(lngCalc <> 0, lngCalc, xlCalculationAutomatic)
    Else
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End If
    .Cursor = IIf(Modus, -4143, 2)
    .CutCopyMode = False
End With

End Sub


Gruß Sepp



Anzeige
+1 fehlt!
29.01.2008 00:33:20
Josef
Hallo Bernhard,
da fehlte noch ein +1.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub copyLines()
Dim objWs As Worksheet, objNewWs As Worksheet

With ThisWorkbook
    On Error Resume Next
    Set objNewWs = .Sheets("Zusammenfassung")
    On Error GoTo 0
    
    On Error GoTo ErrExit
    GMS
    
    If objNewWs Is Nothing Then
        Set objNewWs = .Worksheets.Add(Before:=.Sheets(.Sheets.Count))
        objNewWs.Name = "Zusammenfassung"
    End If
    
    For Each objWs In .Worksheets
        objWs.Rows("3:4").Copy objNewWs.Rows(objNewWs.Cells(Rows.Count, 1).End(xlUp).Row + 1)
        objWs.Rows("12:26").Copy objNewWs.Rows(objNewWs.Cells(Rows.Count, 1).End(xlUp).Row + 1)
    Next
    
End With

ErrExit:
If Err.Number > 0 Then
    MsgBox Err.Number & vbLf & Err.Description
End If
GMS True
Set objWs = Nothing
Set objNewWs = Nothing
End Sub

Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long

With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Modus Then
        .Calculation = IIf(lngCalc <> 0, lngCalc, xlCalculationAutomatic)
    Else
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End If
    .Cursor = IIf(Modus, -4143, 2)
    .CutCopyMode = False
End With

End Sub


Gruß Sepp



Anzeige
AW: +1 fehlt!
29.01.2008 09:44:00
Bernhard
Hallo Sepp,
vielen Dank, bis auf eine Kleinigkeit tut es gut.
Momentan überschreibt er mir die Zeilen 3:4 mit dem Inhalt der nächsten Zeilen.
Ich habe daher einfach mal im zweiten copy das +1 in +3 geändert, und das tut nun.

For Each objWs In .Worksheets
objWs.Rows("3:4").Copy objNewWs.Rows(objNewWs.Cells(Rows.Count, 1).End(xlUp).Row + 1)
objWs.Rows("12:26").Copy objNewWs.Rows(objNewWs.Cells(Rows.Count, 1).End(xlUp).Row + 3)
Next


Und ich habe in meiner Ergebnisliste auch einige Leerzeilen, die ich gerne rausgenommen hätte. Geht das einfach so mit einem "Clean" am Ende?
Danke.
Bernhard

Anzeige
AW: +1 fehlt!
29.01.2008 10:59:01
Josef
Hallo Bernhard,
dann so.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub copyLines()
Dim objWs As Worksheet, objNewWs As Worksheet
Dim lngR As Long, l As Long
Dim rng As Range, rngD As Range
With ThisWorkbook
    On Error Resume Next
    Set objNewWs = .Sheets("Zusammenfassung")
    On Error GoTo 0
    
    On Error GoTo ErrExit
    GMS
    
    If objNewWs Is Nothing Then
        Set objNewWs = .Worksheets.Add(Before:=.Sheets(.Sheets.Count))
        objNewWs.Name = "Zusammenfassung"
    End If
    
    objNewWs.Cells.Clear
    
    lngR = 1
    
    For Each objWs In .Worksheets
        objWs.Rows("3:4").Copy objNewWs.Rows(lngR)
        objWs.Rows("12:26").Copy objNewWs.Rows(lngR + 2)
        lngR = lngR + 17
    Next
    
    For l = 1 To lngR
        If Application.CountA(objNewWs.Rows(l)) = 0 Then
            If rng Is Nothing Then
                Set rng = objNewWs.Rows(l)
            Else
                Set rng = Union(objNewWs.Rows(l), rng)
            End If
        End If
    Next
    
    If Not rng Is Nothing Then rng.Delete
    
End With

ErrExit:

If Err.Number > 0 Then
    MsgBox Err.Number & vbLf & Err.Description
End If

GMS True
Set rng = Nothing
Set objWs = Nothing
Set objNewWs = Nothing
End Sub

Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long

With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Modus Then
        .Calculation = IIf(lngCalc <> 0, lngCalc, xlCalculationAutomatic)
    Else
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End If
    .Cursor = IIf(Modus, -4143, 2)
    .CutCopyMode = False
End With

End Sub


Gruß Sepp



Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige