In vba Makro
Der folgende Code erstellt ein Excel Addin mit einem einfachen Menü in Ribbon:Add-ins
Und einem einzelnen Unterelement als Button zum Ausführen einer Sub-Function
Excel Addin Code
Option Explicit Option Compare Text
'************************************************************** Const °AddinName As String = "Pfade_anpassen"
'*Installation Addin->Menubar
Sub Workbook_AddinInstall() Check_Addin_Menu End Sub
Private Sub Workbook_Open() Check_Addin_Menu End Sub
Sub Check_Addin_Menu() '----------------< Check_Addin_Menu() >----------------
'--< Install_MenuBar >-- 'Dim addin_Commandbar As CommandBar Dim addin_Menu As CommandBarControl Set addin_Menu = find_AddinMenu(°AddinName) '< check > If Not addin_Menu Is Nothing Then addin_Menu.Visible = True Exit Sub End If '</ check >
On Error GoTo 0 '--< Install_MenuBar >--
'< create new > Set addin_Menu = Application.CommandBars(1).Controls.Add(Type:=msoControlPopup, Temporary:=False) addin_Menu.Caption = °AddinName '</ create new >
'< Menue_Punkte_einfuegen > commandBarButton_anfuegen addin_Menu, sText:="Pfade austauschen", sActionName:="fx_Pfade_austauschen", faceID:=893, beginGroup:=False '</ Menue_Punkte_einfuegen >
'< anzeigen > addin_Menu.Visible = True '</ anzeigen >
'----------------</ Check_Addin_Menu() >---------------- End Sub
Private Sub commandBarButton_anfuegen(ByRef subMenu As CommandBarControl, ByVal sText As String, ByVal sActionName As String, ByVal faceID As Integer, ByVal beginGroup As Boolean) '------------< commandBarButton_anfuegen >------------ Dim control_Element As CommandBarButton Set control_Element = subMenu.Controls.Add control_Element.Caption = sText control_Element.OnAction = sActionName control_Element.faceID = faceID control_Element.Style = msoButtonIconAndCaption control_Element.beginGroup = beginGroup '------------</ commandBarButton_anfuegen >------------ End Sub
Sub Workbook_AddinUninstall() '----------------< Uninstall in PowerPoint ??() >--------------- '--< find_commandbar >-- Dim addin_Commandbar As CommandBarControl Set addin_Commandbar = find_AddinMenu(°AddinName) '< check > If Err.Number <> 0 Then Exit Sub If addin_Commandbar Is Nothing Then Exit Sub '</ check > '--</ find_commandbar >--
addin_Commandbar.Delete
'----------------</ Uninstall in PowerPoint ??() >--------------- End Sub
'=====================< Helper-Functions >============== Public Function find_AddinMenu(ByVal sName As String) As CommandBarControl '-----------< find_Commandbar() >-------------- Dim search_Commandbar As CommandBarControl '----< @Loop: all_Commandbars >---- For Each search_Commandbar In Application.CommandBars(1).Controls If search_Commandbar.Caption = sName Then '< match_return > Set find_AddinMenu = search_Commandbar Exit Function 'not necessary '</ match_return > End If Next '----</ @Loop: all_Commandbars >----
'< nomatch > Set find_AddinMenu = Nothing '</ nomatch > '-----------</ find_Commandbar() >-------------- End Function
'=====================</ Helper-Functions >==============
|
Beispiel Code zum tauschen aller Pfad-Strings in Excel in einen neuen Pfad
Option Explicit
'----< SETUP >---- Const °Pfad_Alt = "C:\Demo_Pfad_ALT" Const °Pfad_Neu = "D:\NEUER_PFAD" '----</ SETUP >---- Public Sub fx_Pfade_austauschen() '----------------< fx_Pfade_austauschen() >----------------
'< get_Paths > '='C:\Users\poppr\Desktop\Excel\Excel\20190214_Pfade_aendern\[Excel_mit_Wert_A_inC3.xlsx]Sheet1'!B$2 Dim sPfad_Alt As String sPfad_Alt = °Pfad_Alt sPfad_Alt = LCase(sPfad_Alt)
Dim sPfad_Neu As String sPfad_Neu = °Pfad_Neu sPfad_Neu = LCase(sPfad_Neu) '</ get_Paths >
'< get_Document > Application.StatusBar = Now & " start Pfade austauschen von " & sPfad_Alt & " -> " & sPfad_Neu Dim wb As Workbook Set wb = ActiveWorkbook '</ get_Document > '------< Change_LinkSources >------ '*LinkSources sind echte externe Verknuepfungen in Objekten oder externen Formelbezuegen
On Error Resume Next '*if no ole objects or excelLinks exits Application.DisplayAlerts = False '*dialog bei Link-wechsel unterdruecken
'----< @Loop: LinkSources >---- '*embedded grafiken und excel objekte Dim sLink As Variant For Each sLink In wb.LinkSources(1) '----< IsLinkSource >---- sLink = LCase(sLink) Debug.Print sLink Application.StatusBar = "check " & sLink If sLink Like "*" & sPfad_Alt & "*" Then '---< Contains_Path >--- '< replace > Dim sLink_neu As String sLink_neu = Replace(sLink, sPfad_Alt, sPfad_Neu, , , vbTextCompare) '</ replace >
'< change_linksource > Application.StatusBar = "replace " & sLink wb.ChangeLink sLink, sLink_neu, xlLinkTypeExcelLinks wb.ChangeLink sLink, sLink_neu, xlLinkTypeOLELinks '</ change_linksource > '---</ Contains_Path >--- End If '----</ IsLinkSource >---- Next '----</ @Loop: LinkSources >---- Application.DisplayAlerts = True On Error GoTo 0 '------</ Change_LinkSources >------
'------< Change_Cells >------ '*.Range.Find ( Suchbegriff, Startposition, xlFindLookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte, SearchFormat ) '*xlFindLookIn: XlFormulas, XlValuesoder , XlNotes. '*XlLookAt -Konstanten sein: XlWhole oder XlPart. '*XlSearchOrder -Konstanten sein: XlByRows oder XlByColumns. '*MatchCase Optional Variant True, um die Suche Groß-/Kleinschreibung. Der Standardwert ist False. ' oder Match '=ADDRESS(MATCH(" Excel*",$A$1:$A$100,0),1) '----< @Loop: Worksheets >---- Dim ws As Worksheet For Each ws In wb.Worksheets Dim usedRange As Range Set usedRange = ws.usedRange
Dim cell As Range Dim sValue_Alt As String Dim sValue_Neu As String Dim sText As String
'--< Change_Values >-- Set cell = usedRange.Find(What:=sPfad_Alt, LookIn:=XlFindLookIn.xlValues, LookAt:=XlLookAt.xlPart, MatchCase:=False, SearchOrder:=xlByRows) If Not cell Is Nothing Then Do sValue_Alt = cell.Value sValue_Alt = LCase(sValue_Alt) Application.StatusBar = "cell." & cell.Address ' & " : " & sValue_Alt Debug.Print "cell." & cell.Address & " " & sValue_Alt DoEvents '< aendern >
sValue_Neu = Replace(sValue_Alt, sPfad_Alt, sPfad_Neu, , , vbTextCompare) cell.Value = sValue_Neu '</ aendern > Set cell = usedRange.FindNext()
Loop While Not cell Is Nothing End If '--</ Change_Values >--
'--< Change_Formulas >-- Set cell = usedRange.Find(What:=sPfad_Alt, LookIn:=XlFindLookIn.xlFormulas, LookAt:=XlLookAt.xlPart, MatchCase:=False, SearchOrder:=xlByRows) If Not cell Is Nothing Then Do sValue_Alt = cell.Formula sValue_Alt = LCase(sValue_Alt) Application.StatusBar = "cell." & cell.Address & " " & sValue_Alt Debug.Print "cell." & cell.Address & " " & sValue_Alt DoEvents '< aendern > sValue_Neu = Replace(sValue_Alt, sPfad_Alt, sPfad_Neu, , , vbTextCompare)
cell.Formula = sValue_Neu '</ aendern >
Set cell = usedRange.FindNext()
Loop While Not cell Is Nothing End If '--</ Change_Formulas >--
'--< Change_Comments >-- '*find returns cell as range Set cell = usedRange.Find(What:=sPfad_Alt, LookIn:=XlFindLookIn.xlComments, LookAt:=XlLookAt.xlPart, MatchCase:=False, SearchOrder:=xlByRows) If Not cell Is Nothing Then Do sValue_Alt = cell.Comment.Text sValue_Alt = LCase(sValue_Alt) Application.StatusBar = "cell." & cell.Address & " " & sValue_Alt Debug.Print "cell." & cell.Address & " " & sValue_Alt DoEvents '< aendern > sValue_Neu = Replace(sValue_Alt, sPfad_Alt, sPfad_Neu, , , vbTextCompare)
cell.Comment.Delete cell.AddComment sValue_Neu '</ aendern >
Set cell = usedRange.FindNext()
Loop While Not cell Is Nothing End If '--</ Change_Comments >-- Next '----</ @Loop: Worksheets >----
'------< Names_Variablen >------ Application.StatusBar = "Korrigiere Namensvariablen.."
'Loop durch Links Dim Names_Variable As Name For Each Names_Variable In wb.Names 'Namen prüfen Dim sNames_Pfad As String sNames_Pfad = Names_Variable.RefersToLocal sNames_Pfad = LCase(sNames_Pfad) If InStr(1, sNames_Pfad, sPfad_Alt, vbTextCompare) >= 0 Then sNames_Pfad = Replace(sNames_Pfad, sPfad_Alt, sPfad_Neu, , , vbTextCompare) End If Next '------< Names_Variablen >------
'------</ Change_Cells >------
'< Abschluss > On Error GoTo 0 Application.StatusBar = Now & " Fertig." MsgBox "Fertig" '</ Abschluss > '----------------</ fx_Pfade_austauschen() >---------------- End Sub |