Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.
Clever-Excel-Forum › Office-Anwendungen › Excel v
Nach der Übertragung die Zieltabelle Sortieren

Thema geschlossen 
Baumstrukturmodus
Nach der Übertragung die Zieltabelle Sortieren
DietmarD Offline
Benutzer
ThreadStarter

Registriert seit: 29.09.2016
Version(en): 2007/2010/ 365
#11
01.10.2016, 21:01
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!
Gruß
Dietmar

Damit das Mögliche entsteht, muß immer wieder das Unmögliche versucht werden.  
Suchen
Antworten Top
DietmarD Offline
Benutzer
ThreadStarter

Registriert seit: 29.09.2016
Version(en): 2007/2010/ 365
#12
01.10.2016, 23:49 (Dieser Beitrag wurde zuletzt bearbeitet: 01.10.2016, 23:49 von 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. Laola
Gruß
Dietmar

Damit das Mögliche entsteht, muß immer wieder das Unmögliche versucht werden.  
Suchen
Antworten Top
Kuwer Offline
Excelanwender mit VBA
Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
#13
02.10.2016, 00:03
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
[-] Folgende(r) 1 Nutzer sagt Danke an Kuwer für diesen Beitrag:
  • DietmarD
Suchen
Antworten Top
DietmarD Offline
Benutzer
ThreadStarter

Registriert seit: 29.09.2016
Version(en): 2007/2010/ 365
#14
02.10.2016, 00:27
Hallo Uwe,
Dein neu gestalteter Code, läuft genau wie bei mir nur dann durch, wenn ich auf das Protect verzichte bzw. es Auskommentiere Huh

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:
Gruß
Dietmar

Damit das Mögliche entsteht, muß immer wieder das Unmögliche versucht werden.  
Suchen
Antworten Top
DietmarD Offline
Benutzer
ThreadStarter

Registriert seit: 29.09.2016
Version(en): 2007/2010/ 365
#15
16.10.2016, 08:43
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.
Gruß
Dietmar

Damit das Mögliche entsteht, muß immer wieder das Unmögliche versucht werden.  
Suchen
Antworten Top
schauan Offline
Einer von hier
Registriert seit: 10.04.2014
Version(en): 97-2019 (32) + 365 (64)
#16
16.10.2016, 11:04
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)
.      \\\|///      Hoffe, geholfen zu haben.
       ( ô ô )      Grüße, André aus G in T  
  ooO-(_)-Ooo    (Excel 97-2019+365)
Homepage Suchen
Antworten Top
Kuwer Offline
Excelanwender mit VBA
Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
#17
16.10.2016, 11:49
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
Suchen
Antworten Top
DietmarD Offline
Benutzer
ThreadStarter

Registriert seit: 29.09.2016
Version(en): 2007/2010/ 365
#18
16.10.2016, 12:00
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.
Gruß
Dietmar

Damit das Mögliche entsteht, muß immer wieder das Unmögliche versucht werden.  
Suchen
Antworten Top
DietmarD Offline
Benutzer
ThreadStarter

Registriert seit: 29.09.2016
Version(en): 2007/2010/ 365
#19
19.10.2016, 23:44 (Dieser Beitrag wurde zuletzt bearbeitet: 19.10.2016, 23:50 von 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
Gruß
Dietmar

Damit das Mögliche entsteht, muß immer wieder das Unmögliche versucht werden.  
Suchen
Antworten Top
DietmarD Offline
Benutzer
ThreadStarter

Registriert seit: 29.09.2016
Version(en): 2007/2010/ 365
#20
19.10.2016, 23:59
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. Blush
Gruß
Dietmar

Damit das Mögliche entsteht, muß immer wieder das Unmögliche versucht werden.  
Suchen
Antworten Top
Thema geschlossen 


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste