Daten per VBA übertragen
#1
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!
Gruß
Dietmar

Damit das Mögliche entsteht, muß immer wieder das Unmögliche versucht werden.  
Top
#2
Hallo Dietmar,

zeig doch mal deine Datei.
Viele Grüße
Klaus-Dieter
Der Erfolg hat viele Väter, 
der Misserfolg ist ein Waisenkind
Richard Cobden
Top
#3
Hallo Klaus-Dieter,

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


Angehängte Dateien
.xltm   Schichten.xltm (Größe: 704,21 KB / Downloads: 15)
Gruß
Dietmar

Damit das Mögliche entsteht, muß immer wieder das Unmögliche versucht werden.  
Top
#4
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!
Gruß
Dietmar

Damit das Mögliche entsteht, muß immer wieder das Unmögliche versucht werden.  
Top
#5
Nachfrage zurück gezogen.
Viele Grüße
Klaus-Dieter
Der Erfolg hat viele Väter, 
der Misserfolg ist ein Waisenkind
Richard Cobden
Top
#6
Hallo Dietmar,

(08.02.2018, 08:14)DietmarD schrieb: 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
Top
#7
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?
Gruß
Dietmar

Damit das Mögliche entsteht, muß immer wieder das Unmögliche versucht werden.  
Top
#8
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
Top
#9
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:
Gruß
Dietmar

Damit das Mögliche entsteht, muß immer wieder das Unmögliche versucht werden.  
Top
#10
Hallo Uwe,

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

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


Gehe zu:


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