Namen aller Arbeitsmappe in einem Ordner ändern
24.10.2013 10:55:55
Dingdang
ich möchte anhand den Felderbenennungen einer Arbeitsmappe (nenne ich Mustermappe) die Namen in aller Arbeitsmappen in einem vorgegebenen Ordner anpassen. Ich glaube man kanns direkt lösen oder zuerst die Namen aus Mustermappe auslesen und in einer Tabelle (Infortabelle) speichern und anhand dieser Infortabelle noch die Namenänderung durchführen. Zu diesen zwei Wege habe ich jeweils ne Code geschrieben. Leider funktionieren beide code nicht. Ich bin sehr dankbar falls jemand mir beim Debuggen helfen kann!!
direkte Lösung:
Sub Copy_All_Defined_Names()
Dim x As Name
Const sSourcePath As String = "D:\Dateien\test"
Dim fso As Object, oFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Application.DisplayAlerts = False
For Each oFile In fso.GetFolder(sSourcePath).Files
If LCase(Right(oFile.Name, 5)) = ".xlsm" Then
Application.Workbooks.Open (oFile.Path)
Workbooks("Mustermappe.xlsm").Activate
For Each x In ActiveWorkbook.Names
Workbooks(oFile.Name).Names.Add Name:=x.Name, RefersTo:=x.Value
Debug.Print x
Next x
End If
Next
Application.DisplayAlerts = True
End Sub
Für die indirekte Lösung habe ich schon meine Infortablle vorbereitet mit 3 Spalten: Namen, _
Tabelle und Zelle. Die Einträge unter Namen beziehen sich jeweils auf die Tabelle und _ Zellenangaben in der gleichen Zeile. und nun die Code für die Namenbenennung:
Sub NamenReparatur()
Dim i As Integer
Dim NumNamen As Integer
Worksheets("Infortabelle").Activate
NumNamen = ActiveSheet.UsedRange.Rows.Count
Const sSourcePath As String = "D:\Dateien\test"
Dim fso As Object, oFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Application.DisplayAlerts = False
For Each oFile In fso.GetFolder(sSourcePath).Files
If LCase(Right(oFile.Name, 5)) = ".xlsm" Then
Application.Workbooks.Open (oFile.Path)
For i = 2 To NumNamen
Worksheets(Sheets("Infortabelle").Cells(i, 2).Value).Activate
ActiveSheet.Range(Sheets("Infortabelle").Cells(i, 3).Value).Name = Sheets("Infortabelle").Cells( _
_
_
_
i, 1).Value
Next i
End If
Next
Application.DisplayAlerts = True
End
Sub
Vielen Dank, viele Grüße
Dingdang