Code immer auf geöffnetes Blatt beziehn

Sub cel() ' ANZEIGEN DER TABS In geöffneter Datei test.xlsm Sub adminlogin() ActiveSheet.Unprotect Password:="befaster" Dim Passwort As String, VergleichsPasswort As String VergleichsPasswort = "faster" Passwort = InputBox("Please enter password", "Password query") If Passwort VergleichsPasswort Then Exit Sub Application.CommandBars("Worksheet Menu Bar").Enabled = True 'eingefügt Application.DisplayFullScreen = False 'eingefügt ActiveWindow.DisplayVerticalScrollBar = True 'eingefügt Application.CommandBars("Standard").Visible = True 'geändert Application.CommandBars("Formatting").Visible = True 'geändert ActiveWindow.DisplayWorkbookTabs = True ActiveWindow.DisplayHeadings = True 'geöffneten Tab in Copy.xlsm kopieren in Test.xlsm cells.Select Selection.Copy Windows("Test.xlsm").Activate cells.Select ActiveSheet.Paste End Sub 'Bereichsnamen kopieren Dim WbZiel As Workbook Dim n As Long Dim Nc As Long Nc = ThisWorkbook.Names.Count If Nc > 0 Then Set WbZiel = Workbooks("Test.xlsm") For n = 1 To Nc WbZiel.Names.Add Name:=ThisWorkbook.Names(n).Name, _ RefersTo:=ThisWorkbook.Names(n).RefersTo Next End If ActiveSheet.Protect Password:="befaster", AllowFormattingColumns:=True, AllowFiltering:=True End Sub

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Benutzer

Hallo Maris,
mit nachfolgenden Anpassungen sollte es funktionieren.
Gruß
Franz

Sub Modify_test_xlsm()
Dim wbZiel As Workbook, wbCopy As Workbook
Dim wksZiel As Worksheet, wksCopy As Worksheet
Dim Passwort As String, VergleichsPasswort As String
Dim n As Long
Dim Nc As Long, sName As String, sNameRefersto
VergleichsPasswort = "faster"
Passwort = InputBox("Please enter password", "Password query")
If Passwort  VergleichsPasswort Then Exit Sub
Set wbCopy = ThisWorkbook
wbCopy.Activate
Set wksCopy = ActiveSheet
Set wbZiel = Workbooks("test.xlsm")
wbZiel.Activate
Set wksZiel = ActiveSheet
' ANZEIGEN DER TABS In geöffneter Datei test.xlsm
Application.CommandBars("Worksheet Menu Bar").Enabled = True 'eingefügt
Application.DisplayFullScreen = False 'eingefügt
ActiveWindow.DisplayVerticalScrollBar = True 'eingefügt
Application.CommandBars("Standard").Visible = True 'geändert
Application.CommandBars("Formatting").Visible = True 'geändert
ActiveWindow.DisplayWorkbookTabs = True
ActiveWindow.DisplayHeadings = True
wksZiel.Unprotect Password:="befaster"
'geöffneten Tab in Copy.xlsm kopieren in Test.xlsm
wksCopy.Cells.Copy wksZiel.Cells
'Bereichsnamen kopieren
Nc = wbCopy.Names.Count
If Nc > 0 Then
For n = 1 To Nc
sName = wbCopy.Names(n).Name
sNameRefersto = wbCopy.Names(n).RefersTo
'Namen im Tabellenblatt und Namen mit Konstant-Werten übertragen
If InStr(1, LCase(sNameRefersto), LCase(wksCopy.Name)) > 0 _
Or InStr(1, LCase(sNameRefersto), "!") = 0 Then
If InStr(1, sNameRefersto, "'") = 0 Then
sNameRefersto = Replace(sNameRefersto, wksCopy.Name, "'" & wksZiel.Name & "'")
End If
Application.DisplayAlerts = False
wbZiel.Names.Add Name:=sName, _
RefersTo:=Replace(sNameRefersto, wksCopy.Name, wksZiel.Name)
Application.DisplayAlerts = True
End If
Next
End If
wksZiel.Protect Password:="befaster", AllowFormattingColumns:=True, AllowFiltering:=True
Set wbZiel = Nothing: Set wbCopy = Nothing
Set wksZiel = Nothing: Set wksCopy = Nothing
End Sub

Beliebteste Forumthreads (12 Monate)

Code immer auf geöffnetes Blatt beziehn

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Code immer auf geöffnetes Blatt beziehn

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread