Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
Hallo Dietmar,
auf den Knopf drücken musst Du aber selbst.  Private Sub CommandButton22_Click()
Dim oWbQ As Workbook, oWbZ As Workbook, oWsA As Worksheet
Dim rngQ As Range, rngZelle As Range
Dim strPasswort As String, strPassAlt As String
strPassAlt = "xyz" 'Passwort zum Vergleich hier anpassen
Set oWbQ = ActiveWorkbook 'Exceldaten, die momentan im zugriff ist "merken"
Set oWsA = ActiveSheet
If oWsA.Range("A1") = "0" Then
strPasswort = InputBox("Zum Übertragen bitte Passwort eingeben", "Passwortabfrage")
If strPasswort = strPassAlt Then
If MsgBox("Sollen die Daten übertragen werden?", vbYesNo, "Achtung") = vbYes Then
Application.EnableEvents = False 'Ausschalten eines Ereignisses z.Bsp. Worksheet_Change
Set oWbZ = Workbooks.Open(Filename:="H:\Auswertung\Fehleranteil\Master.Fehleranteil.xlsx") 'Exceldaten, die das Ziel sein _
With oWbQ.Sheets("Fehleranteil").Range("B2:O15")
.Parent.Unprotect
varQ = .Formula
.Value = .Value
If Application.CountBlank(.Cells) < .Cells.Count Then
Set rngQ = Application.Intersect(.EntireColumn, .SpecialCells(xlCellTypeConstants).EntireRow)
End If
.Formula = varQ
.Parent.Protect
End With
If Not rngQ Is Nothing Then 'wenn es etwas zum Kopieren gibt
Set oWbZ = Workbooks.Open(Filename:="H:\Auswertung\Fehleranteil\Master.Fehleranteil.xlsx") 'Exceldaten, die das Ziel sein soll mit Pfad!!!!
With oWbZ.Sheets("Fehleranteil1")
If .Range("A1") = "" Then
Set rngZelle = .Range("A1") 'wenn a1 leer ist bei A2 beginnen
Else
Set rngZelle = .Range("A:x").Find(What:="*", after:=.Range("A1"), LookIn:=xlValues, _
LookAt:=xlWhole, searchdirection:=xlPrevious) 'letzte beschriebene Zelle im bereich "A:AA" ermitteln
End If
End With
rngQ.Copy
rngZelle.Offset(1).EntireRow.Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False 'Werte einfügen
Application.CutCopyMode = False
oWbZ.Close Savechanges:=True
End If
oWsA.Range("A1").Value = "1"
End If
Else
MsgBox "Du hast ein falsches Passwort eingegeben!"
End If
Else
MsgBox "Die Daten wurden bereits übertragen!"
End If
Application.EnableEvents = True 'Ereigniss wieder einschalten wichtig!!!!
Application.Goto (ActiveWorkbook.Sheets("Schichtenprotokoll").Range("A8"))
End Sub Gruß Uwe
Registriert seit: 29.09.2016
Version(en): 2007/2010/ 365
Hallo Uwe,
vielen Dank für Deine hervorragende Arbeit, klappt natürlich einwandfrei. :100:
Wenn ich Deinen Code direkt aus dem Tabellenblatt Fehleranteil über einen Button starte, klappt das wie gewünscht. Wenn ich den Code über einen Button aus dem Tabellenblatt Auswertung aufrufe, dann bekomme ich einen Debbugen bei varQ = .Formula Variabel nicht definiert.
Wenn ich den Code in ein Modul packe und über call aufrufe, habe ich das gleiche Problem.
Wie kann ich da Abhilfe schaffen?
Gruß
Dietmar
Damit das Mögliche entsteht, muß immer wieder das Unmögliche versucht werden.
Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
Hallo Dietmar,
vielleicht so? Private Sub CommandButton22_Click()
Dim oWbQ As Workbook, oWbZ As Workbook, oWsA As Worksheet
Dim rngQ As Range, rngZelle As Range
Dim strPasswort As String, strPassAlt As String
strPassAlt = "xyz" 'Passwort zum Vergleich hier anpassen
Set oWbQ = ActiveWorkbook 'Exceldaten, die momentan im zugriff ist "merken"
Set oWsA = Worksheets("Fehleranteil")
If oWsA.Range("A1") = "0" Then
strPasswort = InputBox("Zum Übertragen bitte Passwort eingeben", "Passwortabfrage")
If strPasswort = strPassAlt Then
If MsgBox("Sollen die Daten übertragen werden?", vbYesNo, "Achtung") = vbYes Then
Application.EnableEvents = False 'Ausschalten eines Ereignisses z.Bsp. Worksheet_Change
Set oWbZ = Workbooks.Open(Filename:="H:\Auswertung\Fehleranteil\Master.Fehleranteil.xlsx") 'Exceldaten, die das Ziel sein _
With oWbQ.Sheets("Fehleranteil").Range("B2:O15")
.Parent.Unprotect
varQ = .Formula
.Value = .Value
If Application.CountBlank(.Cells) < .Cells.Count Then
Set rngQ = Application.Intersect(.EntireColumn, .SpecialCells(xlCellTypeConstants).EntireRow)
End If
.Formula = varQ
.Parent.Protect
End With
If Not rngQ Is Nothing Then 'wenn es etwas zum Kopieren gibt
Set oWbZ = Workbooks.Open(Filename:="H:\Auswertung\Fehleranteil\Master.Fehleranteil.xlsx") 'Exceldaten, die das Ziel sein soll mit Pfad!!!!
With oWbZ.Sheets("Fehleranteil1")
If .Range("A1") = "" Then
Set rngZelle = .Range("A1") 'wenn a1 leer ist bei A2 beginnen
Else
Set rngZelle = .Range("A:x").Find(What:="*", after:=.Range("A1"), LookIn:=xlValues, _
LookAt:=xlWhole, searchdirection:=xlPrevious) 'letzte beschriebene Zelle im bereich "A:AA" ermitteln
End If
End With
rngQ.Copy
rngZelle.Offset(1).EntireRow.Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False 'Werte einfügen
Application.CutCopyMode = False
oWbZ.Close Savechanges:=True
End If
oWsA.Range("A1").Value = "1"
End If
Else
MsgBox "Du hast ein falsches Passwort eingegeben!"
End If
Else
MsgBox "Die Daten wurden bereits übertragen!"
End If
Application.EnableEvents = True 'Ereigniss wieder einschalten wichtig!!!!
Application.Goto (ActiveWorkbook.Sheets("Schichtenprotokoll").Range("A8"))
End Sub Lösche auch die rot gekennzeichnete Zeile!
Gruß Uwe
Registriert seit: 29.09.2016
Version(en): 2007/2010/ 365
Hallo Uwe,
Danke für deine Antwort!
Code eingefügt rote Zeile gelöscht und trozdem bleibt der Code bei varQ = .Formula stehen mit der Meldung "Variable nicht definiert"
Gruß
Dietmar
Damit das Mögliche entsteht, muß immer wieder das Unmögliche versucht werden.
Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
Hallo Dietmar,
dann deklariere sie halt! So wie hier: http://www.clever-excel-forum.de/thread-...#pid109506
Gruß Uwe
Registriert seit: 29.09.2016
Version(en): 2007/2010/ 365
Hallo Uwe,
danke für deine super Arbeit hier, habe ich hinbekommen.
Vielen dank für deine Geduld mit einem VBA Legastheniker. 
Klappt einwandfrei. :15:
Gruß
Dietmar
Damit das Mögliche entsteht, muß immer wieder das Unmögliche versucht werden.
|
