✔ Excel - Schleife mit Tabellennamen

Yaslaw · 14. Januar 2019

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 · 14. Januar 2019

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

Yaslaw · 14. Januar 2019

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 · 15. Januar 2019

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

✔ Excel - Schleife mit Tabellennamen

Yaslaw

alter Rempler

jerry0110

Erfahrenes Mitglied

Yaslaw

alter Rempler

jerry0110

Erfahrenes Mitglied

Neue Beiträge