Thema: Tabellenblätter kopieren, wenn Email-Adresse vorhanden

StandardModule: Modul1

Sub CopyWks()
   Dim wkb As Workbook
   Dim wks As Worksheet
   Dim sEmail
   Application.ScreenUpdating = False
   sEmail = InputBox("Email-Adresse:", , "hans@herber.de")
   If sEmail = "" Then Exit Sub
   Set wkb = ThisWorkbook
   For Each wks In wkb.Worksheets
      If wks.Range("C5").Value = sEmail Then
         If wkb.Name = ActiveWorkbook.Name Then
            wks.Copy
         Else
            wks.Copy after:=Worksheets(Worksheets.Count)
         End If
      End If
   Next wks
   Worksheets(1).Select
   ActiveSheet.Buttons.Delete
   Rows("7:16").Delete
   Application.ScreenUpdating = True
End Sub

Beiträge aus dem Excel-Forum zu den Themen Allgemein und Vergleich