AW: Benannte Bereiche in Tabellenblatt-Kopien
16.09.2015 05:42:42
fcs
Hallo Jens,
ich persönlich würde hier bei der Verarbeitung unter VBA die Variante mit gleichen Namen in jedem Arbeitsblatt vorziehen. Durch Verwendung einer Objektvariablen, die gleich dem entsprechenden Blatt gesetzt wird, wird Code doch übersichtlich und strukturiert.
Beispiel für beide Varianten:
Sub DoSomething()
Call aaTest(strPref:="aa")
Call bbTest(strSheet:="Test 01")
End Sub
Sub aaTest(ByVal strPref As String)
'Bereich der Namen ist Arbeitsmappe
Dim rngNamen As Range
Dim rngOrte As Range
Set rngNamen = Application.Range(strPref & "_Namen")
Set rngOrte = Application.Range(strPref & "_Orte")
End Sub
Sub bbTest(ByVal strSheet As String)
'Bereich der Namen ist Tabellenblatt
Dim wks As Worksheet
Dim rngNamen As Range
Dim rngOrte As Range
Set wks = Worksheets(strSheet)
Set rngNamen = wks.Range("Namen")
Set rngOrte = wks.Range("Orte")
End Sub
Du kannst aber mal probieren, ob das nachfolgende Makro dich deinem Ziel näher bringt.
Gruß
Franz
ub BlattKopieren_Namen_neue_Prefix()
Dim wkb As Workbook
Dim wksAlt As Worksheet
Dim wksNeu As Worksheet
Dim strPrefAlt As String, strPrefNeu As String
Dim objName As Name, objNameCopy As Name
Dim strNameAlt As String, strNameNeu As String
Dim strBlattNeu As String
Dim strTitel As String
Set wkb = ActiveWorkbook
Set wksAlt = ActiveSheet
strTitel = "Blatt kopieren und Namen umbenennen"
strPrefAlt = InputBox("Namens-Prefix in der Quelltabelle """ _
& wksAlt.Name & """?", strTitel, "aa_")
If strPrefAlt = "" Then GoTo Beenden
BlattKopieren:
strBlattNeu = InputBox("Blattname für kopierte Tabelle?", _
strTitel, wksAlt.Name & " (2)")
If strBlattNeu = "" Then GoTo Beenden
If fncCheckSheet(strBlattNeu) = True Then
MsgBox "Der eingegebene Blattname existiert bereits", _
vbOKOnly, strTitel
GoTo BlattKopieren
End If
strPrefNeu = InputBox("Neue Namens-Prefix in der kopierten Tabelle?", _
strTitel, strPrefAlt)
If strPrefNeu = "" Then GoTo Beenden
If LCase(strPrefNeu) = LCase(strPrefAlt) Then
MsgBox "Pre-Fix alt und neu müssen verschieden sein!!", _
vbOKOnly, strTitel
Exit Sub
End If
wksAlt.Copy after:=wksAlt
Set wksNeu = ActiveSheet
For Each objName In wkb.Names
If Left(objName.Name, Len(strPrefAlt)) = strPrefAlt Then
strNameAlt = objName.Name
strNameNeu = strPrefNeu & Mid(strNameAlt, Len(strPrefAlt) + 1)
Set objNameCopy = wkb.Names("'" & wksNeu.Name & "'!" & strNameAlt)
wkb.Names.Add Name:=strNameNeu, RefersTo:="='" & wksNeu.Name & "'!" _
& wksNeu.Range(strNameAlt).Address
objNameCopy.Delete
End If
Next
wksNeu.Name = strBlattNeu
If MsgBox("Weitere Kopie erstellen?", _
vbQuestion + vbOKCancel, strTitel) = vbOK Then GoTo BlattKopieren
Beenden:
End Sub
Public Function fncCheckSheet(ByVal strName, Optional wkb As Workbook) As Boolean
'Prüft, ob Blattname in Arbeitsmappe vorhanden ist - True = vorhanden
Dim objSheet As Object
On Error GoTo Fehler
If wkb Is Nothing Then Set wkb = ActiveWorkbook
Set objSheet = wkb.Sheets(strName)
fncCheckSheet = True
Exit Function
Fehler:
End Function