Anzeige

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("Automatisierung NOC.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\NOC Test verzeichnis\" & 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("Automatisierung NOC.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\NOC Test verzeichnis\" & 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
 

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 Automatisierung NOC.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.
 

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\Jerome.linden\Desktop\"
sFile = Dir(sPath & "Liste Jerome.csv")
zFile = "Liste_Jerome"
Application.ScreenUpdating = False
             
If Dir(sPath & "Liste Jerome.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"

ActiveWorkbook.Worksheets.Add.Name = "Allinq"
ActiveWorkbook.Worksheets.Add.Name = "Artemis"
ActiveWorkbook.Worksheets.Add.Name = "BAM"
ActiveWorkbook.Worksheets.Add.Name = "Condata"
ActiveWorkbook.Worksheets.Add.Name = "Dinkhoff"
ActiveWorkbook.Worksheets.Add.Name = "DNS"
ActiveWorkbook.Worksheets.Add.Name = "Euromicron"
ActiveWorkbook.Worksheets.Add.Name = "Fa. Pohl"
ActiveWorkbook.Worksheets.Add.Name = "Fritsche"
ActiveWorkbook.Worksheets.Add.Name = "Grethen"
ActiveWorkbook.Worksheets.Add.Name = "GVO"
ActiveWorkbook.Worksheets.Add.Name = "HAK"
ActiveWorkbook.Worksheets.Add.Name = "IGW"
ActiveWorkbook.Worksheets.Add.Name = "MIH"
ActiveWorkbook.Worksheets.Add.Name = "Mühlbauer"
ActiveWorkbook.Worksheets.Add.Name = "Potex"
ActiveWorkbook.Worksheets.Add.Name = "Qron"
ActiveWorkbook.Worksheets.Add.Name = "R&R Heming"
ActiveWorkbook.Worksheets.Add.Name = "RKE"
ActiveWorkbook.Worksheets.Add.Name = "RSW"
ActiveWorkbook.Worksheets.Add.Name = "Siers Telecom"
ActiveWorkbook.Worksheets.Add.Name = "SPIE"
ActiveWorkbook.Worksheets.Add.Name = "Suptel"
ActiveWorkbook.Worksheets.Add.Name = "Terrado"
ActiveWorkbook.Worksheets.Add.Name = "TKU"
ActiveWorkbook.Worksheets.Add.Name = "Van den Donk"
ActiveWorkbook.Worksheets.Add.Name = "Van Gelder Telekom"
ActiveWorkbook.Worksheets.Add.Name = "VIB"
ActiveWorkbook.Worksheets.Add.Name = "Volker Wessels Telekom"
ActiveWorkbook.Worksheets.Add.Name = "VPT"

End Sub


Private Sub Kopie_Daten()

Dim myDate As Date
myDate = datum
ActiveWorkbook.Worksheets("Tabelle1").Activate

    Dim source As Worksheet, target1 As Worksheet, target2 As Worksheet, target3 As Worksheet
    Dim target4 As Worksheet, target5 As Worksheet, target6 As Worksheet, target7 As Worksheet
    Dim target8 As Worksheet, target9 As Worksheet, target10 As Worksheet, target11 As Worksheet
    Dim target12 As Worksheet, target13 As Worksheet, target14 As Worksheet, target15 As Worksheet
    Dim target16 As Worksheet, target17 As Worksheet, target18 As Worksheet, target19 As Worksheet
    Dim target20 As Worksheet, target21 As Worksheet, target22 As Worksheet, target23 As Worksheet
    Dim target24 As Worksheet, target25 As Worksheet, target26 As Worksheet, target27 As Worksheet
    Dim target28 As Worksheet, target29 As Worksheet, target30 As Worksheet

    Dim LastRowNrInTarget1 As Long, LastRowNrInTarget2 As Long, LastRowNrInTarget3 As Long
    Dim LastRowNrInTarget4 As Long, LastRowNrInTarget5 As Long, LastRowNrInTarget6 As Long
    Dim LastRowNrInTarget7 As Long, LastRowNrInTarget8 As Long, LastRowNrInTarget9 As Long
    Dim LastRowNrInTarget10 As Long, LastRowNrInTarget11 As Long, LastRowNrInTarget12 As Long
    Dim LastRowNrInTarget13 As Long, LastRowNrInTarget14 As Long, LastRowNrInTarget15 As Long
    Dim LastRowNrInTarget16 As Long, LastRowNrInTarget17 As Long, LastRowNrInTarget18 As Long
    Dim LastRowNrInTarget19 As Long, LastRowNrInTarget20 As Long, LastRowNrInTarget21 As Long
    Dim LastRowNrInTarget22 As Long, LastRowNrInTarget23 As Long, LastRowNrInTarget24 As Long
    Dim LastRowNrInTarget25 As Long, LastRowNrInTarget26 As Long, LastRowNrInTarget27 As Long
    Dim LastRowNrInTarget28 As Long, LastRowNrInTarget29 As Long, LastRowNrInTarget30 As Long
    Dim i
 
    Set source = ActiveWorkbook.Worksheets("Tabelle1")
    Set target1 = ActiveWorkbook.Worksheets("Allinq")
    Set target2 = ActiveWorkbook.Worksheets("Artemis")
    Set target3 = ActiveWorkbook.Worksheets("BAM")
    Set target4 = ActiveWorkbook.Worksheets("Condata")
    Set target5 = ActiveWorkbook.Worksheets("Dinkhoff")
    Set target6 = ActiveWorkbook.Worksheets("DNS")
    Set target7 = ActiveWorkbook.Worksheets("Euromicron")
    Set target8 = ActiveWorkbook.Worksheets("Fa. Pohl")
    Set target9 = ActiveWorkbook.Worksheets("Fritsche")
    Set target10 = ActiveWorkbook.Worksheets("Grethen")
    Set target11 = ActiveWorkbook.Worksheets("GVO")
    Set target12 = ActiveWorkbook.Worksheets("HAK")
    Set target13 = ActiveWorkbook.Worksheets("IGW")
    Set target14 = ActiveWorkbook.Worksheets("MIH")
    Set target15 = ActiveWorkbook.Worksheets("Mühlbauer")
    Set target16 = ActiveWorkbook.Worksheets("Potex")
    Set target17 = ActiveWorkbook.Worksheets("Qron")
    Set target18 = ActiveWorkbook.Worksheets("R&R Heming")
    Set target19 = ActiveWorkbook.Worksheets("RKE")
    Set target20 = ActiveWorkbook.Worksheets("RSW")
    Set target21 = ActiveWorkbook.Worksheets("Siers Telecom")
    Set target22 = ActiveWorkbook.Worksheets("SPIE")
    Set target23 = ActiveWorkbook.Worksheets("Suptel")
    Set target24 = ActiveWorkbook.Worksheets("Terrado")
    Set target25 = ActiveWorkbook.Worksheets("TKU")
    Set target26 = ActiveWorkbook.Worksheets("Van den Donk")
    Set target27 = ActiveWorkbook.Worksheets("Van Gelder Telekom")
    Set target28 = ActiveWorkbook.Worksheets("VIB")
    Set target29 = ActiveWorkbook.Worksheets("Volker Wessels Telekom")
    Set target30 = ActiveWorkbook.Worksheets("VPT")
   
    Call source.Rows(1).Copy(Destination:=target1.Rows(1))
    Call source.Rows(1).Copy(Destination:=target2.Rows(1))
    Call source.Rows(1).Copy(Destination:=target3.Rows(1))
    Call source.Rows(1).Copy(Destination:=target4.Rows(1))
    Call source.Rows(1).Copy(Destination:=target5.Rows(1))
    Call source.Rows(1).Copy(Destination:=target6.Rows(1))
    Call source.Rows(1).Copy(Destination:=target7.Rows(1))
    Call source.Rows(1).Copy(Destination:=target8.Rows(1))
    Call source.Rows(1).Copy(Destination:=target9.Rows(1))
    Call source.Rows(1).Copy(Destination:=target10.Rows(1))
    Call source.Rows(1).Copy(Destination:=target11.Rows(1))
    Call source.Rows(1).Copy(Destination:=target12.Rows(1))
    Call source.Rows(1).Copy(Destination:=target13.Rows(1))
    Call source.Rows(1).Copy(Destination:=target14.Rows(1))
    Call source.Rows(1).Copy(Destination:=target15.Rows(1))
    Call source.Rows(1).Copy(Destination:=target16.Rows(1))
    Call source.Rows(1).Copy(Destination:=target17.Rows(1))
    Call source.Rows(1).Copy(Destination:=target18.Rows(1))
    Call source.Rows(1).Copy(Destination:=target19.Rows(1))
    Call source.Rows(1).Copy(Destination:=target20.Rows(1))
    Call source.Rows(1).Copy(Destination:=target21.Rows(1))
    Call source.Rows(1).Copy(Destination:=target22.Rows(1))
    Call source.Rows(1).Copy(Destination:=target23.Rows(1))
    Call source.Rows(1).Copy(Destination:=target24.Rows(1))
    Call source.Rows(1).Copy(Destination:=target25.Rows(1))
    Call source.Rows(1).Copy(Destination:=target26.Rows(1))
    Call source.Rows(1).Copy(Destination:=target27.Rows(1))
    Call source.Rows(1).Copy(Destination:=target28.Rows(1))
    Call source.Rows(1).Copy(Destination:=target29.Rows(1))
    Call source.Rows(1).Copy(Destination:=target30.Rows(1))

   
'letzte Ziele im Ziel berechnen
   LastRowNrInTarget1 = lastRowNr(target1)
   LastRowNrInTarget2 = lastRowNr(target2)
   LastRowNrInTarget3 = lastRowNr(target3)
   LastRowNrInTarget4 = lastRowNr(target4)
   LastRowNrInTarget5 = lastRowNr(target5)
   LastRowNrInTarget6 = lastRowNr(target6)
   LastRowNrInTarget7 = lastRowNr(target7)
   LastRowNrInTarget8 = lastRowNr(target8)
   LastRowNrInTarget9 = lastRowNr(target9)
   LastRowNrInTarget10 = lastRowNr(target10)
   LastRowNrInTarget11 = lastRowNr(target11)
   LastRowNrInTarget12 = lastRowNr(target12)
   LastRowNrInTarget13 = lastRowNr(target13)
   LastRowNrInTarget14 = lastRowNr(target14)
   LastRowNrInTarget15 = lastRowNr(target15)
   LastRowNrInTarget16 = lastRowNr(target16)
   LastRowNrInTarget17 = lastRowNr(target17)
   LastRowNrInTarget18 = lastRowNr(target18)
   LastRowNrInTarget19 = lastRowNr(target19)
   LastRowNrInTarget20 = lastRowNr(target20)
   LastRowNrInTarget21 = lastRowNr(target21)
   LastRowNrInTarget22 = lastRowNr(target22)
   LastRowNrInTarget23 = lastRowNr(target23)
   LastRowNrInTarget24 = lastRowNr(target24)
   LastRowNrInTarget25 = lastRowNr(target25)
   LastRowNrInTarget26 = lastRowNr(target26)
   LastRowNrInTarget27 = lastRowNr(target27)
   LastRowNrInTarget28 = lastRowNr(target28)
   LastRowNrInTarget29 = lastRowNr(target29)
   LastRowNrInTarget30 = lastRowNr(target30)



    For i = lastRowNr(source) To 1 Step -1
     If Cells(i, 4) <= myDate - 2 Then
        'deine Bedinung
       If Cells(i, 11) = "Allinq" Then
            'neue Zeile berechnen
           LastRowNrInTarget1 = LastRowNrInTarget1 + 1
            Call source.Rows(i).Copy(Destination:=target1.Rows(LastRowNrInTarget1))
       
        ElseIf Cells(i, 11) = "Artemis" Then
            'neue Zeile berechnen
           LastRowNrInTarget2 = LastRowNrInTarget2 + 1
            Call source.Rows(i).Copy(Destination:=target2.Rows(LastRowNrInTarget2))
       
        ElseIf Cells(i, 11) = "BAM" Then
            'neue Zeile berechnen
           LastRowNrInTarget3 = LastRowNrInTarget3 + 1
            Call source.Rows(i).Copy(Destination:=target3.Rows(LastRowNrInTarget3))
       
        ElseIf Cells(i, 11) = "Condata" Then
            'neue Zeile berechnen
           LastRowNrInTarget4 = LastRowNrInTarget4 + 1
            Call source.Rows(i).Copy(Destination:=target4.Rows(LastRowNrInTarget4))
       
        ElseIf Cells(i, 11) = "Dinkhoff" Then
            'neue Zeile berechnen
           LastRowNrInTarget5 = LastRowNrInTarget5 + 1
            Call source.Rows(i).Copy(Destination:=target5.Rows(LastRowNrInTarget5))
       
        ElseIf Cells(i, 11) = "DNS" Then
            'neue Zeile berechnen
           LastRowNrInTarget6 = LastRowNrInTarget6 + 1
            Call source.Rows(i).Copy(Destination:=target6.Rows(LastRowNrInTarget6))
       
        ElseIf Cells(i, 11) = "Euromicron" Then
            'neue Zeile berechnen
           LastRowNrInTarget7 = LastRowNrInTarget7 + 1
            Call source.Rows(i).Copy(Destination:=target7.Rows(LastRowNrInTarget7))
       
        ElseIf Cells(i, 11) = "Fa. Pohl" Then
            'neue Zeile berechnen
           LastRowNrInTarget8 = LastRowNrInTarget8 + 1
            Call source.Rows(i).Copy(Destination:=target8.Rows(LastRowNrInTarget8))
       
        ElseIf Cells(i, 11) = "Fritsche" Then
            'neue Zeile berechnen
           LastRowNrInTarget9 = LastRowNrInTarget9 + 1
            Call source.Rows(i).Copy(Destination:=target9.Rows(LastRowNrInTarget9))
       
         ElseIf Cells(i, 11) = "Grethen" Then
            'neue Zeile berechnen
           LastRowNrInTarget10 = LastRowNrInTarget10 + 1
            Call source.Rows(i).Copy(Destination:=target10.Rows(LastRowNrInTarget10))
       
        ElseIf Cells(i, 11) = "GVO" Then
            'neue Zeile berechnen
           LastRowNrInTarget11 = LastRowNrInTarget11 + 1
            Call source.Rows(i).Copy(Destination:=target11.Rows(LastRowNrInTarget11))

        ElseIf Cells(i, 11) = "HAK" Then
            'neue Zeile berechnen
           LastRowNrInTarget12 = LastRowNrInTarget12 + 1
            Call source.Rows(i).Copy(Destination:=target12.Rows(LastRowNrInTarget12))
           
        ElseIf Cells(i, 11) = "IGW" Then
            'neue Zeile berechnen
           LastRowNrInTarget13 = LastRowNrInTarget13 + 1
            Call source.Rows(i).Copy(Destination:=target13.Rows(LastRowNrInTarget13))
           
        ElseIf Cells(i, 11) = "MIH" Then
            'neue Zeile berechnen
           LastRowNrInTarget14 = LastRowNrInTarget14 + 1
            Call source.Rows(i).Copy(Destination:=target14.Rows(LastRowNrInTarget14))
           
        ElseIf Cells(i, 11) = "Mühlbauer" Then
            'neue Zeile berechnen
           LastRowNrInTarget15 = LastRowNrInTarget15 + 1
            Call source.Rows(i).Copy(Destination:=target15.Rows(LastRowNrInTarget15))
           
        ElseIf Cells(i, 11) = "Potex" Then
            'neue Zeile berechnen
           LastRowNrInTarget16 = LastRowNrInTarget16 + 1
            Call source.Rows(i).Copy(Destination:=target16.Rows(LastRowNrInTarget16))
           
        ElseIf Cells(i, 11) = "Qron" Then
            'neue Zeile berechnen
           LastRowNrInTarget17 = LastRowNrInTarget17 + 1
            Call source.Rows(i).Copy(Destination:=target17.Rows(LastRowNrInTarget17))
           
        ElseIf Cells(i, 11) = "R&R Heming" Then
            'neue Zeile berechnen
           LastRowNrInTarget18 = LastRowNrInTarget18 + 1
            Call source.Rows(i).Copy(Destination:=target18.Rows(LastRowNrInTarget18))
           
        ElseIf Cells(i, 11) = "RKE" Then
            'neue Zeile berechnen
           LastRowNrInTarget19 = LastRowNrInTarget19 + 1
            Call source.Rows(i).Copy(Destination:=target19.Rows(LastRowNrInTarget19))
           
        ElseIf Cells(i, 11) = "RSW" Then
            'neue Zeile berechnen
           LastRowNrInTarget20 = LastRowNrInTarget20 + 1
            Call source.Rows(i).Copy(Destination:=target20.Rows(LastRowNrInTarget20))
           
        ElseIf Cells(i, 11) = "Siers Telecom" Then
            'neue Zeile berechnen
           LastRowNrInTarget21 = LastRowNrInTarget21 + 1
            Call source.Rows(i).Copy(Destination:=target21.Rows(LastRowNrInTarget21))
     
        ElseIf Cells(i, 11) = "SPIE" Then
            'neue Zeile berechnen
           LastRowNrInTarget22 = LastRowNrInTarget22 + 1
            Call source.Rows(i).Copy(Destination:=target22.Rows(LastRowNrInTarget22))
       
        ElseIf Cells(i, 11) = "Suptel" Then
            'neue Zeile berechnen
           LastRowNrInTarget23 = LastRowNrInTarget23 + 1
            Call source.Rows(i).Copy(Destination:=target23.Rows(LastRowNrInTarget23))
       
        ElseIf Cells(i, 11) = "Terrado" Then
            'neue Zeile berechnen
           LastRowNrInTarget24 = LastRowNrInTarget24 + 1
            Call source.Rows(i).Copy(Destination:=target24.Rows(LastRowNrInTarget24))
       
        ElseIf Cells(i, 11) = "TKU" Then
            'neue Zeile berechnen
           LastRowNrInTarget25 = LastRowNrInTarget25 + 1
            Call source.Rows(i).Copy(Destination:=target25.Rows(LastRowNrInTarget25))
       
        ElseIf Cells(i, 11) = "Van den Donk" Then
            'neue Zeile berechnen
           LastRowNrInTarget26 = LastRowNrInTarget26 + 1
            Call source.Rows(i).Copy(Destination:=target26.Rows(LastRowNrInTarget26))
       
        ElseIf Cells(i, 11) = "Van Gelder Telekom" Then
            'neue Zeile berechnen
           LastRowNrInTarget27 = LastRowNrInTarget27 + 1
            Call source.Rows(i).Copy(Destination:=target27.Rows(LastRowNrInTarget27))
           
        ElseIf Cells(i, 11) = "VIB" Then
            'neue Zeile berechnen
           LastRowNrInTarget28 = LastRowNrInTarget28 + 1
            Call source.Rows(i).Copy(Destination:=target28.Rows(LastRowNrInTarget28))

        ElseIf Cells(i, 11) = "Volker Wessels Telekom" Then
            'neue Zeile berechnen
           LastRowNrInTarget29 = LastRowNrInTarget29 + 1
            Call source.Rows(i).Copy(Destination:=target29.Rows(LastRowNrInTarget29))
       
        ElseIf Cells(i, 11) = "VPT" Then
            'neue Zeile berechnen
           LastRowNrInTarget30 = LastRowNrInTarget30 + 1
            Call source.Rows(i).Copy(Destination:=target30.Rows(LastRowNrInTarget30))
       
        Else
            Debug.Print i, "'" & ActiveWorkbook.Worksheets("Tabelle1").Cells(i, 9) & "'", "'" & ActiveWorkbook.Worksheets("Tabelle1").Cells(i, 8) & "'"
        End If
     End If
    Next i

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("Automatisierung NOC.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\NOC Test verzeichnis\" & 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
 
Anzeige
Anzeige