Nach der Übertragung die Zieltabelle Sortieren

[DietmarD]

Hallo Uwe,
schon mal vielen Dank für Deine Mühe. Klappt noch nicht ganz wie gewünscht
 
1. bekomme ich einen Debuggen im zweiten Teil des Code Laufzeitfehler 1004 an dieser Stelle

Code:

nwb.Sheets("STO1").Cells(rngZelle.Row + 1, 1).PasteSpecial Paste:=xlPasteValues, Operation:= _
                                  xlNone, SkipBlanks:=False, Transpose:=False 'Werte einfügen

Das Zweite: im ersten Teil des Codes ist ja eine Passwortabfrage und wenn in A1 eine 1 steht, werden die Daten nicht erneut übertragen, was auch so sein soll

das muss natürlich auch für den zweiten Teil gelten, der jetzt trotzdem übertragen würde, wenn ich den Debuggen nicht hätte.

Danke!

[DietmarD]

Hallo Uwe,

habe selbst ein bisschen getüftelt.

Der Debuggen kam auf Grund der Protect in der With Anweisung, den habe ich jetzt Auskommentiert.

Das mit der Passwortabfrage, habe ich ebenfalls selbst hinbekommen, ich habe Else Anweisung mit der MsgBox ans Ende gesetzt.  

Mein Code sieht nun so aus und funktioniert.

Code:

Private Sub CommandButton1_Click()
Dim awb As Workbook, nwb As Workbook
Dim rngZelle As Range
Dim strPasswort As String
Dim strPassalt As String

strPassalt = "xyz"         'Passwort zum Vergleich hier anpassen
'strPasswort = InputBox("Zum Übertragen bitte Passwort eingeben", "Passwortabfrage")
Application.EnableEvents = False       'Ausschalten eines Ereignisses z.Bsp. Worksheet_Change

Set awb = ActiveWorkbook 'Exceldaten, die momentan im zugriff ist "merken"
If 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 = True        'Ereigniss wieder einschalten wichtig!!!!
      'Pfad und Dateinamen anpassen
      'Tabelle1 gegen den Namen der Ziel/Ursprungstabelle austauschen
         
      Set nwb = Workbooks.Open(Filename:="H:\Auswertung\MasterAuswertung.xlsm") 'Exceldaten, die das Ziel sein _
      soll mit Pfad!!!!
      With nwb.Sheets("AuswertungSM4")
        If .Range("a2") = "" Then
          Set rngZelle = .Range("a1") 'wenn a2 leer ist bei A2 beginnen
        Else
         Set rngZelle = .Range("A:AO").Find(What:="*", after:=.Range("A1"), LookIn:=xlValues, _
                       LookAt:=xlWhole, searchdirection:=xlPrevious) 'letzte beschriebene Zelle im bereich "A:V" ermitteln
        End If
      End With
     
      awb.Sheets("AuswertungSM4").Range("A4:Ao4").Copy   'Koppieren
      nwb.Sheets("AuswertungSM4").Cells(rngZelle.Row + 1, 1).PasteSpecial Paste:=xlPasteValues, Operation:= _
      xlNone, SkipBlanks:=False, Transpose:=False                 'Werte einfügen
     
      Application.CutCopyMode = False
      Range("A1").Value = "1"
      Workbooks("MasterAuswertung.xlsm").Close Savechanges:=True
    End If
 

'---------------------------------------------------------------------------------------------------------------------
Set nwb = Workbooks.Open(Filename:="H:\Auswertung\STO.xlsm") 'Exceldaten, die das Ziel sein _
          soll mit Pfad!!!!
With nwb.Sheets("STO1")
  If .Range("a1") = "" Then
    Set rngZelle = Range("a1") 'wenn a1 leer ist bei A2 beginnen
  Else
   Set rngZelle = .Range("A:Y").Find(What:="*", after:=.Range("A1"), LookIn:=xlValues, _
                 LookAt:=xlWhole, searchdirection:=xlPrevious)  'letzte beschriebene Zelle im bereich "A:Y" ermitteln
  End If
End With


With awb.Sheets("Schichtenprotokoll")
  .Unprotect
  With .Range("A42:Y51")
    Application.Intersect(.EntireColumn, .SpecialCells(xlCellTypeConstants).EntireRow).Copy
  End With
  '.Protect
End With
nwb.Sheets("STO1").Cells(rngZelle.Row + 1, 1).PasteSpecial Paste:=xlPasteValues, Operation:= _
                                  xlNone, SkipBlanks:=False, Transpose:=False 'Werte einfügen
 

 Application.CutCopyMode = False
Workbooks("STO.xlsm").Close Savechanges:=True
Else
    MsgBox "Du hast ein falsches Passwort eingegeben!"
    Exit Sub
  End If
Else
  MsgBox "Die Daten wurden bereits übertragen!"
End If
End Sub

Ich werde noch ein bisschen testen und das Thema dann als erledigt kennzeichnen.
Für Deine Hilfe ein großes Dankeschön, ich werde jetzt öfter hier anwesend sein, es hat Spaß gemacht.

[Kuwer]

Hallo Dietmar,

ich war auch dran und habe einiges geändert. Das ist das Ergebnis, wie ich es verstanden habe. Vergleiche mal mit Deiner.

Private Sub CommandButton1_Click()
 Dim oWbQ As Workbook, oWbZ As Workbook, oWsA As Worksheet
 Dim 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\MasterAuswertung.xlsm") 'Exceldaten, die das Ziel sein _
                                                                                   soll mit Pfad!!!!
       With oWbZ.Sheets("AuswertungSM4")
         If .Range("A2") = "" Then
           Set rngZelle = .Range("A1") 'wenn a2 leer ist bei A2 beginnen
         Else
          Set rngZelle = .Range("A:AO").Find(What:="*", After:=.Range("A1"), LookIn:=xlValues, _
                        LookAt:=xlWhole, searchdirection:=xlPrevious) 'letzte beschriebene Zelle im bereich "A:V" ermitteln
         End If
       End With
       
       oWbQ.Sheets("AuswertungSM4").Range("A4:AO4").Copy   'Kopieren
       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
       
       '---------------------------------------------------------------------------------------------------------------------
       Set oWbZ = Workbooks.Open(Filename:="H:\Auswertung\STO.xlsx") 'Exceldaten, die das Ziel sein soll mit Pfad!!!!
       With oWbZ.Sheets("STO1")
         If .Range("A1") = "" Then
           Set rngZelle = .Range("A1") 'wenn a1 leer ist bei A2 beginnen
         Else
           Set rngZelle = .Range("A:Y").Find(What:="*", After:=.Range("A1"), LookIn:=xlValues, _
                        LookAt:=xlWhole, searchdirection:=xlPrevious)  'letzte beschriebene Zelle im bereich "A:Y" ermitteln
         End If
       End With
       
       With oWbQ.Sheets("Schichtenprotokoll")
         .Unprotect
         With .Range("A42:Y51")
           Application.Intersect(.EntireColumn, .SpecialCells(xlCellTypeConstants).EntireRow).Copy
         End With
         .Protect
       End With
       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
       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!!!!
End Sub

Gruß Uwe

[DietmarD]

Hallo Uwe,
Dein neu gestalteter Code, läuft genau wie bei mir nur dann durch, wenn ich auf das Protect verzichte bzw. es Auskommentiere

Ist aber nicht schlimm, das Protect brauche ich nicht unbedingt, es wird auch beim Schließen der Datei gesetzt.

Die Else Anweisung, hast Du genau so gesetzt wie ich auch.

Vielen dank für deine Mühe, Du bist super!   :18:

[DietmarD]

Hallo Uwe,

ich habe dann doch noch mal eine Frage zu diesem Thema.

Ich habe das Problem wenn der zweite Codeabschnitt läuft, das ich einen Debuggen bekomme, wenn der zu kopierende Zellteil  leer ist.

Code:

With .Range("A42:y51")
    Application.Intersect(.EntireColumn, .SpecialCells(xlCellTypeConstants).EntireRow).Copy

Dies würde ich gerne über ON Error abfangen, bin mir aber nicht sicher wie und an welcher Stelle ich die Funktion einbauen kann.

[schauan]

Hallöchen,

Du könntest z.B. vor dem Kopieren prüfen, ob was da ist - z.B. .SpecialCells(xlCellTypeConstants).Cells.Count (falls Du die Stelle meinst)

[Kuwer]

Hallo Dietmar,

wenn alle Zellen leer sind, braucht man die Zielmappe ja gar nicht erst öffnen.
Das sieht dann z.B. so aus:

Private Sub CommandButton1_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\MasterAuswertung.xlsm") 'Exceldaten, die das Ziel sein _
                                                                                  soll mit Pfad!!!!
      With oWbZ.Sheets("AuswertungSM4")
        If .Range("A2") = "" Then
          Set rngZelle = .Range("A1") 'wenn a2 leer ist bei A2 beginnen
        Else
         Set rngZelle = .Range("A:AO").Find(What:="*", After:=.Range("A1"), LookIn:=xlValues, _
                       LookAt:=xlWhole, searchdirection:=xlPrevious) 'letzte beschriebene Zelle im bereich "A:V" ermitteln
        End If
      End With
      
      oWbQ.Sheets("AuswertungSM4").Range("A4:AO4").Copy   'Kopieren
      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
      
      '---------------------------------------------------------------------------------------------------------------------
      With oWbQ.Sheets("Schichtenprotokoll").Range("A42:Y51")
         If Application.CountBlank(.Cells) < .Cells.Count Then
           .Parent.Unprotect
           Set rngQ = Application.Intersect(.EntireColumn, .SpecialCells(xlCellTypeConstants).EntireRow)
           .Parent.Protect
         End If
      End With
      
      If Not rngQ Is Nothing Then  'wenn es etwas zum Kopieren gibt
         Set oWbZ = Workbooks.Open(Filename:="H:\Auswertung\STO.xlsx") 'Exceldaten, die das Ziel sein soll mit Pfad!!!!
         With oWbZ.Sheets("STO1")
           If .Range("A1") = "" Then
             Set rngZelle = .Range("A1") 'wenn a1 leer ist bei A2 beginnen
           Else
             Set rngZelle = .Range("A:Y").Find(What:="*", After:=.Range("A1"), LookIn:=xlValues, _
                          LookAt:=xlWhole, searchdirection:=xlPrevious)  'letzte beschriebene Zelle im bereich "A:Y" 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
         oWsA.Range("A1").Value = "1"
       End If
     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!!!!
End Sub

Gruß Uwe

[DietmarD]

Hallo Uwe,

vielen Dank für Deine Mühe.  :23: 

Wenn ich die Funktion getestet habe, gebe ich Dir ein Feedback.
Ich wünsche Dir noch einen schönen Sonntag.

[DietmarD]

Hallo Uwe,
habe jetzt endlich Zeit gefunden denn Code ausgiebig zu testen.

Bis auf eine Kleinigkeit ist alles so wie gewünscht und der Code läuft ohne Debuggen durch. Aber.....

Mein Anliegen war ja, das wenn die Zellen, die an die STO übertragen werden leer sind und einen Debuggen verursachen, diesen mit On Error abzufangen.
Deine Lösung funktioniert, und wenn ich das richtig verstehe, überträgt er erst gar nicht an die STO wenn der Bereich leer ist, was ebenfalls i.O. ist, aber in diesem Fall, wird dann in meiner Ausgangstabelle nicht mehr die 1 in A1 gesetzt, die eine zweite Übertragung unmöglich macht, was mit der MsgBox erklärt wird.

Das heißt, auch wenn der leere Bereich nicht übertragen wird, weil er halt leer ist, sollte die 1 trotzdem in A1 stehen.
Ich glaube, es handelt sich um diesen Code Teil.

Code:

oWsA.Range("A1").Value = "1"

Vielen Dank für deine Mühe

[DietmarD]

Hallo Uwe,
ich glaube ich habe es selbst hinbekommen,
habe den Codeabschnitt unter die erste End If gesetzt, jetzt sieht es aus als wenn alles läuft.