mehrere Tabellen in Code einbauen
04.11.2004 16:53:16
Armin
ich benutze den unten stehenden Code. Bitte fragt mich nicht nach der dazugehörenden Tabelle. Ich kann sie nicht mitschicken.
Im oberen Teil des Codes wird das Tabellenblatt "Armin" gewählt. Ist das Tabellenblatt nicht in der Mappe enthalten kommt die Nachricht "Die gesuchte Tabelle befindet sich in der Mappe 'send_bcollext.xls'." Anschließend werden in der Tabelle "Armin" unterschiedliche Zeilen gelöscht (siehe Rest vom Code).
Ich möchte nun, dass das nicht nur in der Tabelle "Armin" angewendet werden kann, sondern ich mehrere Tabellen im Code angeben kann. Wie muss ich denn den Code abändern, damit das möglich ist?
Wäre echt wichtig, dass mir da jemand helfen kann. Ich benutze das nämlich echt sehr oft.
Ich bin kein guter Programmierer. Den Code hat mir jemand geschrieben. Ich bräuchte also einen echten Code und nicht einfach nur einen Tipp.
Tausend Danke für die Hilfe!
Gruß
Armin
Private Sub CommandButton5_Click()
On Error GoTo errorhandel
Sheets("Armin").Select
If errorhandel = True Then
errorhandel: MsgBox "Die gesucht Tabelle befindet sich in der Mappe 'send_bcollext.xls'."
Exit Sub
Else
Dim i As Long
Dim j As Long
Dim gefunden As Boolean
Dim BettinaGelöscht As Long
i = 14
j = Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
For j = Cells(Rows.Count, 1).End(xlUp).Row To i Step -1
If gefunden = True Then
Rows(j).Delete Shift:=xlShiftUp
End If
If Cells(j, 1).Value = "DE-Affiliated" Then gefunden = True
Next
For i = 1 To ActiveWindow.SelectedSheets.HPageBreaks.Count
ActiveWindow.SelectedSheets.HPageBreaks(1).Delete
Next i
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=Cells(71, 1)
Rows("15:80").Select
Selection.EntireRow.Hidden = False
Selection.RowHeight = 10.5
Application.ScreenUpdating = True
Dim A As Long, Z As Long, T As String
Const Sp As Long = 1 ' Spalte A=1 , B=2...
A = Cells(Cells.Rows.Count, Sp).End(xlUp).Row
BettinaGelöscht = 0
For Z = A To 1 Step -1
T = Cells(Z, Sp).Value
Select Case T
Case "DE-Anne Sophie", "DE-Pano Service", "DE-Panoramahotel", "Bettina (Füko)", "SK-Hommel", "BR-Solar", "CN-Electronics Hong Kong", "CN-Electronics Tianjin", "DE-Elektronik eiSos", "DE-Elektronik ICS", "DE-Elektronik LPF":
On Error Resume Next
Rows(Z).Delete
Case "Bettina":
If BettinaGelöscht < 2 Then
BettinaGelöscht = BettinaGelöscht + 1
If BettinaGelöscht = 2 Then
Rows(Z).Delete
'If Z > 1 Then
'Z = Z - 1
Rows(Z).Delete
End If
End If
Case "N.N. KF":
Rows(Z).Delete
If Z > 1 Then
Z = Z - 1
Rows(Z).Delete
End If
Case Else:
End Select
Next Z
Range("A11").Select
End If
End Sub