VBA ausführen wenn Reitername XX enthält

Bewerten Sie hier bitte das Excel-Portal

Der kurze Weg zum Ziel: Auftragsprogrammierung

VBA ausführen wenn Reitername XX enthält

VBA ausführen wenn Reitername XX enthält von Lara vom 22.09.2020 11:18:35

AW: VBA ausführen wenn Reitername XX enthält - von peterk am 22.09.2020 11:38:45
- AW: VBA ausführen wenn Reitername XX enthält - von Lara am 22.09.2020 13:12:17
  - AW: VBA ausführen wenn Reitername XX enthält - von Peter (hpo) am 22.09.2020 15:43:23
    - AW: VBA ausführen wenn Reitername XX enthält - von Lara am 22.09.2020 15:55:45
      - Musterdatei? - von UweD am 22.09.2020 16:10:17
AW: VBA ausführen wenn Reitername XX enthält - von UweD am 22.09.2020 11:42:42
- AW: VBA ausführen wenn Reitername XX enthält - von Lara am 22.09.2020 13:08:34
AW: VBA ausführen wenn Reitername XX enthält - von Lara am 25.09.2020 12:11:07

Betrifft: VBA ausführen wenn Reitername XX enthält von: Lara
Geschrieben am: 22.09.2020 11:18:35

Hallo Zusammen,

aktuell habe ich 2 Makros:
Makro 1 kopiert einen Reiter in eine neue Arbeitsmappe, wenn der Reitername XXX enthält.

Sub Kopieren()

Dim Worksheet, Pfad
Dim wb As Workbook

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Pfad = Worksheets("YY").Range("A1")

For Each Worksheet In Worksheets
If Left(Worksheet.name, 4) = "XXX_" Then
    Set wb = Workbooks.Add

    Worksheet.Copy After:=wb.Sheets(wb.Sheets.Count)

    wb.Worksheets(1).Delete

    wb.SaveAs Filename:=Pfad & "\" & Worksheet.name
    wb.Close saveChanges:=True

End If
Next

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Das zweite Makro sperrt und formatiert einen Reiter:

Sub Formatieren() 
   
   Dim Zelle As Range, Zaehler As Integer, Wert As Integer
   
   Wert = CInt(Sheets("YY).Range("D4")) 'Anpassen
   
    With ActiveSheet
       .Unprotect  'Blattschutz aufheben
       .Cells.Locked = True  'alle Zellen im Blatt sperren
             
       For Each Zelle In .Range("F5:Q5")
           Zaehler = Zaehler + 1
           'Zellen nach Prüfung sperren
           If Zaehler < Wert Then
                Zelle.EntireColumn.Copy
                Zelle.EntireColumn.PasteSpecial xlPasteValues
                Application.CutCopyMode = False
           End If
           Zelle.EntireColumn.Locked = (Zaehler < Wert)
        Next Zelle
       .Protect 'Blattschutz setzen
   End With
  
End Sub

Nun möchte ich, dass dieses Makro für alle Reiter ausgeführt wird, die mit "XXX_" beginnen bevor diese Reiter kopiert und in eine neue Arbeitsmappe eingefügt werden.

Das ganze sieht aktuell bei mir so aus.

Sub Kopieren()

Dim Worksheet, Pfad
Dim wb As Workbook
Dim Zelle As Range, Zaehler As Integer, Wert As Integer

Wert = CInt(Sheets("YY).Range("D4")) 'Anpassen

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Pfad = Worksheets("YY").Range("A1")

For Each Worksheet In Worksheets
If Left(Worksheet.name, 4) = "XXX_" Then
 
With ActiveSheet
       .Unprotect  'Blattschutz aufheben
       .Cells.Locked = True  'alle Zellen im Blatt sperren
             
       For Each Zelle In .Range("F5:Q5")
           Zaehler = Zaehler + 1
           'Zellen nach Prüfung sperren
           If Zaehler < Wert Then
                Zelle.EntireColumn.Copy
                Zelle.EntireColumn.PasteSpecial xlPasteValues
                Application.CutCopyMode = False
           End If
           Zelle.EntireColumn.Locked = (Zaehler < Wert)
        Next Zelle
       .Protect 'Blattschutz setzen
   End With    

    Set wb = Workbooks.Add

    Worksheet.Copy After:=wb.Sheets(wb.Sheets.Count)

    wb.Worksheets(1).Delete

    wb.SaveAs Filename:=Pfad & "\" & Worksheet.name
    wb.Close saveChanges:=True

End If
Next

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Aber das Formatierungsmakro wird nicht ausgeführt.

Hat eine/r von euch eine Idee, woran es liegen könnte?

Vielen Dank und

Grüße

Lara

Betrifft: AW: VBA ausführen wenn Reitername XX enthält
von: peterk
Geschrieben am: 22.09.2020 11:38:45

Hallo

Statt

 
With ActiveSheet


With Worksheet

Betrifft: AW: VBA ausführen wenn Reitername XX enthält
von: Lara
Geschrieben am: 22.09.2020 13:12:17

Hallo Peter,

nein - klappt leider immer noch nicht.
Das Formatierungsmakro wird nicht ausgeführt. Es werden nur die files erstellt.

Viele Grüße,
Lara

Betrifft: AW: VBA ausführen wenn Reitername XX enthält
von: Peter (hpo)
Geschrieben am: 22.09.2020 15:43:23

Hallo Lara,

vieleicht klapp es so (nicht getetstet)

Sub Kopieren()
    
    Dim Worksheet, Pfad
    Dim wb As Workbook
    Dim Zelle As Range, Zaehler As Integer, Wert As Integer
    
    Wert = CInt(Sheets("YY).Range("D4")) 'Anpassen
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Pfad = Worksheets("YY").Range("A1")
    
    For Each Worksheet In Worksheets
    If Left(Worksheet.Name, 4) = "XXX_" Then
        
    With Sheets(Worksheet.Name)
           .Unprotect  'Blattschutz aufheben
           .Cells.Locked = True  'alle Zellen im Blatt sperren
                 
           For Each Zelle In .Range("F5:Q5")
               Zaehler = Zaehler + 1
               'Zellen nach Prüfung sperren
               If Zaehler < Wert Then
                    Zelle.EntireColumn.Copy
                    Zelle.EntireColumn.PasteSpecial xlPasteValues
                    Application.CutCopyMode = False
               End If
               Zelle.EntireColumn.Locked = (Zaehler < Wert)
            Next Zelle
           .Protect 'Blattschutz setzen
       End With
    
        Set wb = Workbooks.Add
    
        Worksheet.Copy After:=wb.Sheets(wb.Sheets.Count)
    
        wb.Worksheets(1).Delete
    
        wb.SaveAs Filename:=Pfad & "\" & Worksheet.Name
        wb.Close saveChanges:=True
    
    End If
    Next
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    End Sub

Viele Grüße
Peter (hpo)

Betrifft: AW: VBA ausführen wenn Reitername XX enthält
von: Lara
Geschrieben am: 22.09.2020 15:55:45

Hallo Peter (hpo),

leider funktioniert auch deine Lösung nicht.

Grüße,
Lara

Betrifft: Musterdatei?
von: UweD
Geschrieben am: 22.09.2020 16:10:17

Betrifft: AW: VBA ausführen wenn Reitername XX enthält
von: UweD
Geschrieben am: 22.09.2020 11:42:42

Hallo

verzichte darauf Variablennamen wie VBA Befehle etc. zu benennen

so?? ungetestet

Option Explicit
Sub Kopieren()

    Dim ws, Pfad
    Dim wb As Workbook
    Dim Zelle As Range, Zaehler As Integer, Wert As Integer
    
    Wert = CInt(Sheets("YY").Range("D4")) 'Anpassen
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Pfad = Worksheets("YY").Range("A1")
    
    For Each ws In Worksheets
        If Left(ws.Name, 4) = "XXX_" Then
         
            With ws
                .Unprotect  'Blattschutz aufheben
                .Cells.Locked = True  'alle Zellen im Blatt sperren
                         
                For Each Zelle In .Range("F5:Q5")
                    Zaehler = Zaehler + 1
                    'Zellen nach Prüfung sperren
                    If Zaehler < Wert Then
                        Zelle.EntireColumn.Copy
                        Zelle.EntireColumn.PasteSpecial xlPasteValues
                        Application.CutCopyMode = False
                    End If
                    Zelle.EntireColumn.Locked = (Zaehler < Wert)
                Next Zelle
                .Protect 'Blattschutz setzen
            End With
            
            Set wb = Workbooks.Add
        
            ws.Copy After:=wb.Sheets(wb.Sheets.Count)
        
            wb.Worksheets(1).Delete
        
            wb.SaveAs Filename:=Pfad & "\" & ws.Name
            wb.Close saveChanges:=True
        
        End If
    Next
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

LG UweD

Betrifft: AW: VBA ausführen wenn Reitername XX enthält
von: Lara
Geschrieben am: 22.09.2020 13:08:34

Hallo Uwe,

hat leider immer noch nicht geklappt.
Die neuen files werden zwar erstellt, aber das Formatieren und Sperren davor wird nicht durch geführt.

Grüße
Lara

Betrifft: AW: VBA ausführen wenn Reitername XX enthält
von: Lara
Geschrieben am: 25.09.2020 12:11:07

Hallo Zusammen, Vielen Dank für Eure Unterstützung. Ich konnte mein Problem in der Zwischenzeit lösen =)

Grüße,
Lara

Beiträge aus dem Excel-Forum zum Thema "VBA ausführen wenn Reitername XX enthält"

Makro nach Verlassen einer Zelle ausführen

Zeichenfolgen ändern, wenn ein sie einen bestimmten Text enthalten

Kein Eintrag, bevor ein Wert in Zelle A1 enthalten ist

Dialogaufruf, wenn zwei Zellen Werte enthalten

Herbers Excel/VBA-Archiv

Der kurze Weg zum Ziel: Auftragsprogrammierung

VBA ausführen wenn Reitername XX enthält

Beiträge aus dem Excel-Forum zum Thema "VBA ausführen wenn Reitername XX enthält"