29.04.2018, 13:26
Hallo Dietmar,
auf den Knopf drücken musst Du aber selbst.
auf den Knopf drücken musst Du aber selbst.
Private Sub CommandButton22_Click()Gruß Uwe
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