Daten per VBA übertragen

[DietmarD]

Hallo zusammen,

ich habe ein Problem beim Übertragen von Werten ich eine andere Datei.
Eine ähnliches Thema, hatte ich hier schon mal angefragt, in dem mir hier sehr geholfen wurde!
Mein Ziel ist es aus der aktiven Datei aus dem Tabellenblatt Fehleranteil den Bereich B2:o15 ohne Leerzeilen zu kopieren und in die Zieldatei "H:\Auswertung\Fehleranteil\Master.Fehleranteil.xlsx
in das Tabellenblatt Fehleranteilt1 in den Bereich ab A2 einzutragen, danach immer wieder in die nächste leere Zeile!
Das Ganze mit einer Passwortabfrage und mit Verhinderung, dass die Werte zweimal übertragen werden.
Das Thema, in dem mir dies bezüglich geholfen wurde, heißt: "Nach der Übertragung die Zieltabelle Sortieren"
Den Code, den ich mir zusammen gebastelt habe, sieht so aus:

Code:

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")
        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\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

 
Er bleibt in der Zeile:
Set rngQ = Application.Intersect(.EntireColumn, .SpecialCells(xlCellTypeConstants).EntireRow)
hängen und ich weiß nicht warum.
Vielen Dank für Eure Hilfe!

[Klaus-Dieter]

Hallo Dietmar,

zeig doch mal deine Datei.

[DietmarD]

Hallo Klaus-Dieter,

hier die Datei
Es handelt sich um das Tabellenblatt Fehleranteil CommandButton22!
Danke für dein Interesse!

[DietmarD]

Hallo und guten Morgen,
kann mir den jemand sagen was mit dieser Zeile pasieren muss? Damit ich einen Anhalspunkt wo ich suchen kann!

Set rngQ = Application.Intersect(.EntireColumn, .SpecialCells(xlCellTypeConstants).EntireRow)

Danke!

[Klaus-Dieter]

Nachfrage zurück gezogen.

[Kuwer]

Hallo Dietmar,

kann mir den jemand sagen was mit dieser Zeile pasieren muss? Damit ich einen Anhalspunkt wo ich suchen kann!

Set rngQ = Application.Intersect(.EntireColumn, .SpecialCells(xlCellTypeConstants).EntireRow)

alle Zellen des Bereiches rngQ enthalten Formeln, weshalb es keine einzige Zelle mit einem Wert (xlCellTypeConstants) geben kann.

Die vorherige Prüfung

If Application.CountBlank(.Cells) < .Cells.Count Then

wird auch immer Wahr ergeben, weil es keine leeren Zellen gibt, da sie alle Formeln enthalten.

Gruß Uwe

[DietmarD]

Hallo Uwe,
vielen Dank für deine Antwort.

Kann ich denn irgendwie erreichen, das mir nur die Zellen kopiert werden die errechnete Werte enthalten und ohne Leerzeilen in die Zieltabelle übertragen werden?

[Kuwer]

Hallo Dietmar,

teste mal so:

  Dim rngQ As Range

 Dim varQ As Variant

 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

Die Formeln werden temporär in Werte umgewandelt.

Gruß Uwe

[DietmarD]

Hallo Uwe,

entschuldige das ich mich erst jetzt melde aber ich kann zu Hause im Moment keine Ecxel Dateien mit Makros öffnen bzw bearbeiten.
Der Fehler der angezeigt wird ist:
 
"Klasse ist nicht registriert.
Suche nach Objekt mit
CLSID:{AC9F2F90-E877-11CE-9F68-00AA00574A4F}"


Die Hilfen die ich mir ergooglet habe, brachten bisher keinen Erfolg.


Der Code von dir funktioniert vielen Dank dafür :18:

[DietmarD]

Hallo Uwe,

kannst du mir helfen den von dir geposteten Code in meinen zu integrieren.
Danke.