Code immer auf geöffnetes Blatt beziehn

Forumthread: Code immer auf geöffnetes Blatt beziehn

Maris

Hi Leute,
der folgende Code besteht aus 3 Teilen und wird von/aus der Datei Copy.xlsm ausgeführt.
Die Aktionen sollen sich immer auf die Datei test.xlsm beziehen.
Kann mir bitte jemande den Code anpassen?
Gruß
Maris

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

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Benutzer

AW: Code immer auf geöffnetes Blatt beziehn

fcs

AW: Code immer auf geöffnetes Blatt beziehn

21.05.2011 12:48:38

fcs

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

Forumthread: Code immer auf geöffnetes Blatt beziehn

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread