Excel - Schleife mit Tabellennamen


jerry0110

Erfahrenes Mitglied
#1
Hallo zusammen,

ich habe in meinem Projekt eine Mail-Funktion, wo ich per Makro ein Tabellenblatt anspreche und dann eine Email verschicke.
Die Werte sind natürlich statisch und das möchte ich ändern, weil ich 30 Tabellenblätter habe die ich ansprechen möchte.

Eine Schleife die die Anzahl der Tabellenblätter zählt bekomme ich ohne Probleme hin. Dann weiß ich zwar wie viele Tabellenblätter es gibt, aber nicht die Namen.
Wie kann ich mir jetzt die Namen anzeigen lassen?

Visual Basic:
Dim i

For i = 0 To Worksheets.Count

      MsgBox i

Next i

End Sub
Ziel soll sein, in dir For Schleife die Email Funktion reinzupacken, die sich dann je Tabellenblatt ändert mit Ansprechpartner und Emailadresse.
 

Yaslaw

n/a
Moderator
#2
Visual Basic:
For i = 0 To Worksheets.Count - 1
    sheetName = Worksheets(i).Name
Next i
oder noch schöner
Visual Basic:
Dim ws As Worksheet
for each ws in Worksheets
    sheetName = ws.name
Next ws
 

jerry0110

Erfahrenes Mitglied
#3
So jetzt noch mal mit Erklärung im Code, was ich überhaupt machen möchte. Ich bekomme immer Typ Unverträglichkeit bei source.

Code:
Sub Daten_speichern()

Dim ws As Worksheet
Dim SheetName As String

For Each ws In Worksheets
       
    SheetName = ws.Name
   
    Dim source As Workbooks
    Dim sOrdner As String
    Dim sblattname As String
    Dim sFilename As String
    Dim myDate As Date
    Dim i As Integer
    myDate = datum
   
    'Werte aus source für Schleife (FEHLER!! Typ unverträglich)
    Set source = Workbooks("xxx.xlsm").Worksheets("Makros")
   
    'Schleife für Ordner Erstellung & Speichern der Datei im richtigem Ordner
    For i = lastRowNr(source) To 7 Step -1
       
        'Wenn der Wert in source der gleiche ist wie vom SheetName dann Exit
        If source.Range("A" & i).Value = SheetName Then Exit Sub
       
        'Ordner wo der Ordner sein soll
        sOrdner = "L:\Global\xxx\" & Format(datum, "YYYY") & "\" & SheetName
        sblattname = Format(datum, "YYYYMMDD") & "_" & SheetName & ".xls"
       
        'Wenn Ordner nicht vorhanden, dann anlegen
        If Dir(sOrdner, vbDirectory) = "" Then
            MkDir (sOrdner)
        End If
       
        sFilename = Application.GetSaveAsFilename(sOrdner & sblattname, "Micrsoft Excel-Dateien (*.xls),*.xls")
       
        'Fehler wird hier auch angezeigt bei ws.Activate'
        ws.Activate
        ActiveSheet.Copy
        ActiveWorkbook.SaveAs sFilename, FileFormat:=xlNormal
        ActiveWorkbook.Close False
   Next i
Next ws

End Sub
 
Zuletzt bearbeitet:

jerry0110

Erfahrenes Mitglied
#4
Habe den Code jetzt angepasst, das die Fehler nicht mehr kommen.
Aber er erstellt keinen Ordner und will die Datei auch nicht in dem vorgegebenen Ordner speichern.
Und er will immer das gleiche Sheet speichern.

Visual Basic:
Sub Daten_speichern()

Dim ws As Worksheet
Dim SheetName As String

For Each ws In Worksheets
     
    SheetName = ws.Name
 
    Dim source As Worksheet
    Dim sOrdner As String
    Dim sblattname As String
    Dim sFilename As String
    Dim myDate As Date
    Dim i As Integer
    myDate = datum
 
    'Werte aus source für Schleife
    Set source = Workbooks("xxx.xlsm").Worksheets("Makros")
 
    'Schleife für Ordner Erstellung & Speichern der Datei im richtigem Ordner
    For i = lastRowNr(source) To 7 Step -1
     
        'Ordner wo der Ordner sein soll
            sOrdner = "L:\Global\xxxx\" & Format(datum, "YYYY") & "\" & SheetName & "\"
            sblattname = Format(datum, "YYYYMMDD") & "_" & SheetName & ".xls"
     
        'Wenn Ordner nicht vorhanden, dann anlegen
            If Dir(sOrdner, vbDirectory) <> "" Then
                MkDir sOrdner
            End If
     
            sFilename = Application.GetSaveAsFilename(sOrdner & sblattname, "Micrsoft Excel-Dateien (*.xls),*.xls")
         
            ws.Activate
            ActiveSheet.Copy
            ActiveWorkbook.SaveAs sFilename, FileFormat:=xlNormal
            ActiveWorkbook.Close False

   Next i
Next ws

End Sub
 
Zuletzt bearbeitet:

Yaslaw

n/a
Moderator
#5
Du setzt deine Source zwar jedes mal neu, aber es ist immer dasselbe Sheet
Set source = Workbooks("Automatisierung NOC.xlsm").Worksheets("Makros")
Dann iterierst du über jede Zeile. Pro Zeile speicherst du. Und zwar in den Ordenr, denn du auswählst und nicht in den Ordner den du erstellst.

Was willst du denn machen? Ich verstehe das ab dem Code nicht.
 

jerry0110

Erfahrenes Mitglied
#6
Ich habe in der xxx.xlsm im Sheet Makros eine Liste von Namen.
Ich möchte, dass er diese Liste durch geht und dann prüft, gibt es passend zum Sheet den passenden Ordner. Wenn nicht dann erstell diesen Ordner. Am Ende soll er dann den Sheet in den passenden Ordner speichern.
 
Zuletzt bearbeitet:

Yaslaw

n/a
Moderator
#7
Warum fragst du jeweils nach dem Speicherort?
sFilename = Application.GetSaveAsFilename(sOrdner & sblattname, "Micrsoft Excel-Dateien (*.xls),*.xls")
 

jerry0110

Erfahrenes Mitglied
#8
Muss ich den nicht angeben, wenn ich am Schluss einfüge? Damit Excel weiß wohin er das speichern soll?

Visual Basic:
ActiveWorkbook.SaveAs sFilename, FileFormat:=xlNormal
 

jerry0110

Erfahrenes Mitglied
#10
Vielleicht muss ich vorher noch was schreiben.

Also die Automatisierung NOC.xlsm ist nur eine Datei wo das Makro gespeichert ist.
Der Rest wird in einer neu erstellten Datei gemacht.

Das Makro macht aus einer CSV eine Excel und ordnet Inhalte anhand einer Spalte im Sheet und kopiert diese dann in das richtige Sheet. Das klappt. Da die neu erstellte Excel Datei ja aktiv ist und ich dann aber aus der Automatisierung NOC.xlsm die Liste abrufen möchte muss ja dann auf die andere Excel verweisen.

Dann soll er das oben angegebene Script ausführen.

Ich hoffe das habe ich jetzt verständlich erklärt.
 

Yaslaw

n/a
Moderator
#11
Es macht alles für mich trotzdem keinen Sinn. Du hast Dinge in der ersten Schleife, di vor die Schleife gehören.
Dann sagst du, dass es nicht im automatischen Ordner speichert und gleichzeitig kannst du von Hand eingeben wo es gespeichert werden soll.
Zudem leist du irgendwelche Datensätze aus Automatisierung NOC.xlsm heraus und wendest sie mit jedem Sheet an. Also wird jedes Sheet mehrfach gespeichert.

Irgendwo ist da ein gewaltiges Durcheinander drin.
 

jerry0110

Erfahrenes Mitglied
#12
Hier mal der ganze Code. Vielleicht macht das dann mehr Sinn :)

Visual Basic:
Option Explicit

Private Function xlsGetLastRow(ByRef sheet As Object) As Long
    Const xlCellTypeLastCell = 11

    'Zur letzten initialisierten Zeile gehen
   xlsGetLastRow = sheet.Cells.SpecialCells(xlCellTypeLastCell).Row

    'Von dort zurücksuchen bis zur Letzten zeile mit Inhalt
   Do While sheet.Application.WorksheetFunction.CountA(sheet.Rows(xlsGetLastRow)) = 0 And xlsGetLastRow > 1
        xlsGetLastRow = xlsGetLastRow - 1
    Loop
End Function

Private Function lastRowNr(ByRef ws As Worksheet)

    lastRowNr = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row
  
End Function

Public Function xlsGetLastColumn(ByRef sheet As Object) As Long
    Const xlCellTypeLastCell = 11

    'Zur letzten initialisierten Zeile gehen
   xlsGetLastColumn = sheet.Cells.SpecialCells(xlCellTypeLastCell).Column

    'Von dort zurücksuchen bis zur Letzten zeile mit Inhalt
   Do While sheet.Application.WorksheetFunction.CountA(sheet.Columns(xlsGetLastColumn)) = 0 And xlsGetLastColumn > 1
        xlsGetLastColumn = xlsGetLastColumn - 1
    Loop
End Function

'Private Function datum() As Date
'    If Weekday(Date, vbMonday) = 1 Then
'        datum = Date - 3
'    Else
'        datum = Date - 1
'    End If
'End Function

Private Function datum() As Date

datum = ThisWorkbook.Worksheets("Makros").Range("A3")

End Function

Sub Report()

Dim sFile As String, sPath As String, iFree As Integer
Dim arrCSV, arrTmp, arrXLS(), i As Long, j As Integer, n As Long
Dim zFile As String
Dim source As Worksheet
Dim antwort As Integer

Set source = ActiveWorkbook.Worksheets("Makros")
                          
sPath = "C:\Users\xxx\Desktop\"
sFile = Dir(sPath & "Liste Jerome.csv")
zFile = "Liste_xxx"
Application.ScreenUpdating = False
            
If Dir(sPath & "Liste xxx.csv") <> vbNullString Then

'   Do While Len(sFile)
    
        iFree = FreeFile
        Open sPath & sFile For Input As iFree
        arrCSV = Split(Input(LOF(iFree), iFree), vbCrLf)
        Close iFree
      
    For i = 0 To UBound(arrCSV)
        arrTmp = Split(arrCSV(i), ";")
        n = Application.Max(n, UBound(arrTmp))
    Next
      
        ReDim arrXLS(1 To UBound(arrCSV) + 1, 1 To n + 1)
    For i = 0 To UBound(arrCSV)
       arrTmp = Split(arrCSV(i), ";")
      
          For j = 0 To UBound(arrTmp)
              arrXLS(i + 1, j + 1) = arrTmp(j)
          Next
    Next
      
    With Workbooks.Add
        .Sheets(1).Cells(1, 1).Resize(UBound(arrXLS), UBound(arrXLS, 2)) = arrXLS
        .SaveAs sPath & zFile
    End With

'Loop
End If

Call Seite_erstellen
Call Kopie_Daten
Call Seite_einrichten
Call Zeilenumbruch
Call Spalten_alle_Worksheets
Call Rahmenlinien
Call Daten_speichern


Application.DisplayAlerts = False
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.DisplayAlerts = True

antwort = MsgBox("Wollen Sie die Daten löschen?", vbYesNo + vbQuestion)

'If antwort = vbYes Then
'    Kill source.Range("B2") & source.Range("G5") & "*.xls"
'    Kill source.Range("B2") & source.Range("G5") & "*.csv"
'Else
'    Exit Sub
'End If

End Sub


Private Sub Seite_erstellen()

ActiveWorkbook.Worksheets("Tabelle1").Activate
Range(Cells(1, 1), Cells(1, 12)).Interior.ColorIndex = 6
Range(Cells(1, 1), Cells(1, 12)).Font.Bold = True
Range("G1").Value = "Priorität"



End Sub


Private Sub Seite_einrichten()

Dim source As Worksheet
ActiveWorkbook.Worksheets("Tabelle1").Activate
For Each source In Worksheets

    With source.PageSetup
        .Orientation = xlLandscape
        .PaperSize = xlPaperA4
        .PrintArea = "$A$1:$L$" & lastRowNr(source)
        .FitToPagesWide = 1
        .FitToPagesTall = 6
        .Zoom = 38
        .LeftMargin = Application.CentimetersToPoints(0.5)
        .RightMargin = Application.CentimetersToPoints(0.5)
        .HeaderMargin = Application.CentimetersToPoints(0.3)
        .TopMargin = Application.CentimetersToPoints(0)
        .FooterMargin = Application.CentimetersToPoints(0.3)
        .BottomMargin = Application.CentimetersToPoints(0)
        .CenterFooter = ""
        .RightFooter = "Erstellt am " & Format(Date, "DD.MM.YYYY")
        .LeftFooter = "Daten vom " & datum
    End With
  
Next

End Sub

Private Sub Zeilenumbruch()
ActiveWorkbook.Worksheets("Tabelle1").Activate
Dim source As Worksheet

For Each source In Worksheets

    source.Columns("A:AD").WrapText = True

Next

End Sub



Private Sub Spalten_alle_Worksheets()
ActiveWorkbook.Worksheets("Tabelle1").Activate
Dim source As Worksheet

For Each source In Worksheets

    source.Columns("A:A").ColumnWidth = 19
    source.Columns("B:B").ColumnWidth = 8.5
    source.Columns("C:C").ColumnWidth = 99
    source.Columns("D:D").ColumnWidth = 11
    source.Columns("E:E").ColumnWidth = 8
    source.Columns("F:F").ColumnWidth = 15.6
    source.Columns("G:G").ColumnWidth = 9.3
    source.Columns("H:H").ColumnWidth = 19.8
    source.Columns("I:I").ColumnWidth = 10
    source.Columns("J:J").ColumnWidth = 12.3
    source.Columns("K:K").ColumnWidth = 22.3
    source.Columns("L:L").ColumnWidth = 11.7

    source.Rows("1:2000").AutoFit
  Next
End Sub

Private Sub Rahmenlinien()

Dim source As Worksheet
Dim lastRow As Long
Dim lastCol As Long
Dim rowNr As Long
Dim rng As Range
ActiveWorkbook.Worksheets("Tabelle1").Activate
For Each source In Worksheets

lastRow = xlsGetLastRow(source)
lastCol = xlsGetLastColumn(source)
  
Set rng = source.Range("A1", source.Cells(lastRow, lastCol))

With rng.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = 1
End With

With rng.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = 1
End With

With rng.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = 1
End With

With rng.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = 1
End With

With rng.Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = 1
End With

With rng.Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = 1
End With
Next

End Sub

Sub Daten_speichern()

Dim ws As Worksheet
Dim SheetName As String

For Each ws In Worksheets
      
    SheetName = ws.Name
  
    Dim source As Worksheet
    Dim sOrdner As String
    Dim sblattname As String
    Dim sFilename As String
    Dim myDate As Date
    Dim i As Integer
    myDate = datum
  
    'Werte aus source für Schleife
    Set source = Workbooks("xxx.xlsm").Worksheets("Makros")
  
    'Schleife für Ordner Erstellung & Speichern der Datei im richtigem Ordner
    For i = lastRowNr(source) To 7 Step -1
      
        'Ordner wo der Ordner sein soll
            sOrdner = "L:\Global\xxx\" & Format(datum, "YYYY") & "\" & SheetName & "\"
            sblattname = Format(datum, "YYYYMMDD") & "_" & SheetName
      
        'Wenn Ordner nicht vorhanden, dann anlegen
            If Dir(sOrdner, vbDirectory) <> "" Then
                MkDir sOrdner
            End If
      
            sFilename = Application.GetSaveAsFilename(sOrdner & sblattname, "Micrsoft Excel-Dateien (*.xls),*.xls")
          
            ws.Activate
            ActiveSheet.Copy
            ActiveWorkbook.SaveAs sFilename
            ActiveWorkbook.Close False

   Next i
Next ws

End Sub
Über Vorschläge wie ich es besser machen kann...gerne :)
 
Zuletzt bearbeitet:

Yaslaw

n/a
Moderator
#13
Sorry, Nein, Excel-Code ohne Excel-Sheets sind nicht lesbar.
Und ich will auch nicht dein Code analysieren um herauszufinden was du ev. willst.
Beschreibe dein Vorgang. Benenne die Dinge. "Das andere File" sagt ganze und gar nix.

Und auch im Code. Niemals mit Select arbeiten. Immer mit klaren Variabeln, di nachdem benannt sind, was sie benihalten

Hier mal dein Speichercode überarbeitet, damit er lesbar ist.
Der folgende Code macht dasselbe wie deiner. BEi der Analyse fiel mit auf, dassa du deine Automatieiserung überhaubt nicht auswertest. Ohne die Logik dessen zu kennen, kann ich nicht sagen was da gemacht werden soll

Visual Basic:
Sub Daten_speichern()

    'Dim wbAutomatisierung As Workbook
    'Dim wsZiele As Worksheet

    Dim wbData As Workbook
    Dim ws As Worksheet

    Dim wbTarget As Workbook

    Dim sParentPath As String
    Dim sOrdner As String
    Dim sblattname As String
    Dim sFilename As String
    Dim myDate As Date
    'Dim rowNrZiele As Integer

    'Yalsaw: Die Automatisierung wird nirgends verwendet ausser zum durchiterieren 
    '        ohne das etwas ausgewertet wird. Also weg damit
    'Set wbAutomatisierung = Workbooks("Automatisierung NOC.xlsm")
    'set wsZiele = wbAutomatisierung.Worksheets("Makros")
    
    'Yaslaw: Annahme. das Aktuelle Workbook beinhlatet die Sheets, die gespeichert werden sollten    '
    Set wbData = ActiveWorkbook

    'Yaslaw: Woher kommt datum?
    'Original: myDate = datum
    'Ich nehm mal das aktuelle datum
    myDate = date()

    sParentPath = "L:\Global\NOC Test verzeichnis\" & Format(datum, "YYYY") & "\"

    For Each ws In wbData.Worksheets           
        'Schleife für Ordner Erstellung & Speichern der Datei im richtigem Ordner
        'Yalaw: eine For-Schleife und dann mit jeder Zeile was machen ,acht keinen Sinn.
        '       ganz allgemein, "Automatisierung NOC.xlsm wird eh für nix verwendet
        'For rowNrZiele = lastRowNr(wsZiele) To 7 Step -1
           
        'Ordner wo der Ordner sein soll
        sOrdner = sParentPath & ws.Name & "\"
        'Yaslaw: sBlattname? der Name ist verwirrend. Du brauchst das nachher als Dateiname, nicht als Blatname
        sblattname = Format(datum, "YYYYMMDD") & "_" & ws.Name
       
        'Wenn Ordner nicht vorhanden, dann anlegen
        If Dir(sOrdner, vbDirectory) <> "" Then
            MkDir sOrdner
        End If
   
        'Yaslaw: Sinnlos, Ein Dateiname solte automatisch generiert werden
        sFilename = Application.GetSaveAsFilename(sOrdner & sblattname, "Micrsoft Excel-Dateien (*.xls),*.xls")

        'Yaslaw das aktuelle Worksheet in eine neue Datei kopieren und speichern
        Set wbTarget = Workbooks.Add
        ws.Copy wbTarget.Worksheets(1)      'Vor dem leeren Blatt einfügen'
        wbTarget.SaveAs sFilename
        wbTarget.Close
       'Next rowNrZiele
    Next ws

End Sub
 

jerry0110

Erfahrenes Mitglied
#14
Kann gelöscht werden. Ich mach das jetzt nicht mit einer Schleife.
Ich mach das jetzt einzeln je Sheet mit Abfrage ob gefüllt und dann speichern.
Kann geschlossen werden