Makro überfordert mich

Liebe Excel-Freunde
Ich benötige ein kleines Makro welches mich momentan komplett überfordert... Folgendes müsste das Makro können:

- Neues Worksheet mit Namen « Zusammenfassung » erstellen
- Aus allen bereits erstellten Worksheets den Wert der Zelle B3 kopieren und im Worksheet « Zusammenfassung » in Spalte A (vertikal) kopieren. Für jedes Blatt eine neue Zeile beginnen
- Aus allen bereits erstellten Worksheets die Werte unterhalb der Zelle A6 kopieren (bis zur ersten leeren Zelle) und ins Worksheet « Zusammenfassung » in die Zeile 1 (horizontal) hinein kopieren.
- Aus allen bereits erstellten Worksheets die Werte unterhalb der Zelle B6 kopieren (bis zur ersten leeren Zelle) und ins Worksheet « Zusammenfassung » in die Zeile 2 (ab B2 horizontal) hinein kopieren und dabei für jedes Worksheet eine neue Zeile erstellen.

Konkret heisst das : Das Makro erstellt im neuen Worksheet eine Zusammenfassung aller vorangehenden Blätter. In Spalte A stehen die Namen von Personen, in Zeile 1 die Kriterien und im Bereich B2 bis xxx die erreichten Werte.
Kann mir da jemand helfen ?

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
bin nicht sicher ob ich alles verstanden habe!
Kannst aber mal diesen Code testen.

Sub Start()
Dim oWS() As Worksheet, i%
Dim nRow&, nCount&
Dim strNewName$
strNewName = "Zusammenfassung"
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    
    With ThisWorkbook
        For i = 1 To .Worksheets.Count
            If Not .Sheets(i).Name Like strNewName & "*" Then
                nCount = nCount + 1
                Redim Preserve oWS(1 To nCount)
                Set oWS(i) = ThisWorkbook.Worksheets(i)
            End If
        Next i
        
        nCount = 1
        With .Sheets.Add(After:=.Sheets(.Sheets.Count))
            .Name = CheckTabelle("Zusammenfassung")
            For i = Lbound(oWS) To Ubound(oWS)
                
                oWS(i).Cells(3, 2).Copy .Cells(nCount, 1)
                
                nRow = oWS(1).Cells(oWS(1).Rows.Count, 1).End(xlUp).Row
                If nRow > 6 Then
                    oWS(1).Range(oWS(1).Cells(6, 1), oWS(1).Cells(nRow, 1)).Copy
                    .Cells(nCount, 2).PasteSpecial xlPasteValues, Transpose:=True
                End If
                 nCount = nCount + 1
                nRow = oWS(1).Cells(oWS(1).Rows.Count, 2).End(xlUp).Row
                If nRow > 6 Then
                    oWS(1).Range(oWS(1).Cells(6, 2), oWS(1).Cells(nRow, 2)).Copy
                    .Cells(nCount, 2).PasteSpecial xlPasteValues, Transpose:=True
                End If
                nCount = nCount + 2
            Next i
            Application.Goto .Cells(1, 1), True
        End With
    End With

    
    .CutCopyMode = False
    .DisplayAlerts = True
    .ScreenUpdating = True
    .EnableEvents = True
End With
End Sub

Function CheckTabelle(ByVal strForgabe$)
Dim i%, iRet As VbMsgBoxResult, booCheck As Boolean
On Error Resume Next
booCheck = ThisWorkbook.Sheets(strForgabe).Index > 0
If booCheck Then
    iRet = MsgBox("Tabelle '" & strForgabe & "' schon vorhanden, diese löschen?", vbQuestion + vbYesNo)
    If iRet = vbYes Then
        ThisWorkbook.Sheets(strForgabe).Delete
    End If
    booCheck = False
End If
Do While booCheck = True
    i = i + 1
    strForgabe = strForgabe & i
    booCheck = False
    booCheck = ThisWorkbook.Sheets(strForgabe).Index > 0
Loop
CheckTabelle = strForgabe
End Function

Gruß Tino

Beliebteste Forumthreads (12 Monate)

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

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread