AW: Zelleninhalte in Register kopieren + Format
01.09.2007 18:20:31
fcs
Hallo Lemmi,
ich hab in das Makro eine Eingabebox eingebaut zur Eingabe der Nr. der Kopie. Bei Nr. = 1 wird der Blattname wie bisher festgelegt. Bei Nr 1 wird die eingegebene Nummer in () angefügt.
Zur Abarbeitung einer anderen Spalte (hier G) hab ich eine Variante des Makros erstellt.
Damit solltest du weiter kommen.
Gruß
Franz
Sub Arbeitsblatt_Kopieren_Spalte()
Dim TB_Basis As Worksheet, TB_Ref As Worksheet, TB_Neu As Worksheet, RefDaten As Range
Dim KopieNr, Zelle As Range
KopieNr = InputBox("Kopie Nummer: " & vbLf & vbLf _
& "Bei Nummer >1 wird die KopieNr in ( ) dem Blattnamen hinzugefügt", _
"Tabellen Blätter kopieren, Referenztabelle Spalte C", 1)
If KopieNr = "" Then Exit Sub 'Abrechen wurde gewählt
Set TB_Basis = Worksheets("Basetabelle")
Set TB_Ref = Worksheets("Referenztabelle")
With TB_Ref
Set RefDaten = .Range(.Cells(6, 3), .Cells(.Rows.Count, 3).End(xlUp))
For Each Zelle In RefDaten
If Not IsEmpty(Zelle) Then
TB_Basis.Copy After:=Worksheets(Worksheets.Count)
Set TB_Neu = ActiveSheet
TB_Neu.Name = Zelle.Value & " " & Zelle.Offset(0, 3).Value & _
IIf(KopieNr = "1", "", "(" & KopieNr & ")")
'Button in Kopie löschen
TB_Neu.Shapes(1).Delete
End If
Next Zelle
End With
End Sub
Sub Arbeitsblatt_Kopieren_Spalte_G()
Dim TB_Basis As Worksheet, TB_Ref As Worksheet, TB_Neu As Worksheet, RefDaten As Range
Dim KopieNr, Zelle As Range, Spalte As Integer
KopieNr = InputBox("Kopie Nummer: " & vbLf & vbLf _
& "Bei Nummer >1 wird die KopieNr in ( ) dem Blattnamen hinzugefügt", _
"Tabellen Blätter kopieren, Referenztabelle Spalte G", 1)
If KopieNr = "" Then Exit Sub 'Abrechen wurde gewählt
Spalte = 7 'Spalte G
Set TB_Basis = Worksheets("Basetabelle")
Set TB_Ref = Worksheets("Referenztabelle")
With TB_Ref
Set RefDaten = .Range(.Cells(6, Spalte), .Cells(.Rows.Count, Spalte).End(xlUp))
For Each Zelle In RefDaten
TB_Basis.Copy After:=Worksheets(Worksheets.Count)
Set TB_Neu = ActiveSheet
TB_Neu.Name = Zelle.Value & " " & Zelle.Offset(0, 6 - Zelle.Column).Value & _
IIf(KopieNr = "1", "", "(" & KopieNr & ")")
'Button in Kopie löschen
TB_Neu.Shapes(1).Delete
Next Zelle
End With
End Sub