Makro überfordert mich

Forumthread: Makro überfordert mich

29.10.2013 11:31:07

Dani

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 ?

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Makro überfordert mich

29.10.2013 14:29:13

Tino
eine Zeile noch anpassen

29.10.2013 14:31:30

Tino
alle oWS(1) auf oWS(i) ändern? Gruß

29.10.2013 15:49:34

robert
ja genau hab ich übersehen! oT.

29.10.2013 15:52:48

Tino

AW: Makro überfordert mich

29.10.2013 14:29:13

Tino

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

eine Zeile noch anpassen

29.10.2013 14:31:30

Tino

Hallo,
passe diese Zeile


.Name = CheckTabelle("Zusammenfassung")

so an


.Name = CheckTabelle(strNewName)

Gruß Tino

alle oWS(1) auf oWS(i) ändern? Gruß

29.10.2013 15:49:34

robert

ja genau hab ich übersehen! oT.

29.10.2013 15:52:48

Tino

Beliebteste Forumthreads (12 Monate)

Forumthread: Makro überfordert mich

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

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread