in bestehenden Code benannten Bereich einfügen
27.03.2016 20:48:49
MB12
Hallo zusammen,
nachdem mir Michael einen tollen Code "gezaubert" hat, den ich dann noch erfolgreich erweitert habe, fehlt mir noch eine Kleinigkeit. Ich starte einen Beitrag, da Michael einige Tage nicht da ist:
Ich möchte jeweils in die damit neu erzeugten Blätter (ca 30) einen benannten Bereich aus einem anderen Tabellenblatt einfügen. Der Bereich heißt "krit" (siehe unten.) Das wär's eigentlich schon. Der Code:
Option Explicit
Sub Zusatzblatt2()
Dim vorhSh As String, shName As String
Dim actSh As Worksheet, laufSh As Worksheet
Dim actShNr&, neuesShNr&, maxShNr&, i&, z&, maxzeile&, von&
Set actSh = ActiveSheet
vorhSh = "!" ' Ausrufezeichen kann NICHT im Blattnamen vorhanden sein...
For Each laufSh In Worksheets: vorhSh = vorhSh & laufSh.Name & "!": Next
maxzeile = actSh.Range("A" & actSh.Rows.Count).End(xlUp).Row
von = 2
For z = 2 To maxzeile
If actSh.Range("A" & z) = "" Then
shName = Mid(actSh.Range("A" & von).Value, 7)
If shName = "" Then: MsgBox "Phase_XXX???": Exit Sub
If InStr(vorhSh, "!" & shName & "!") = 0 Then
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = shName
vorhSh = vorhSh & shName & "!"
End If
actSh.Range("A" & von & ":C" & z).Copy Sheets(shName).Range("B5")
Sheets(shName).Range("B5:D" & z - von + 1).FormulaLocal = "=" & actSh.Name & "!A" & von
von = z + 1
'ab A25 den benannten Bereich "krit" (A1:B23) aus Blatt "Bild" einfügen
Columns("A:A").ColumnWidth = 7
Columns("B:B").ColumnWidth = 15
Columns("C:C").ColumnWidth = 20
Columns("D:E").ColumnWidth = 10
Rows("25:90").RowHeight = 20
ActiveWindow.DisplayZeros = False
Range("A1").Value = ActiveSheet.Name & "2"
Range("A1").Font.ColorIndex = 15
End If
Next
End Sub
Danke schon jetzt sehr herzlich.
Margarete