Eingegebene Daten in seperate Excel Datei übertragen und speichern

[Jnine]

Guten Morgen,

Super, vielen dank es funktioniert  
Eine Frage hätte ich da noch  :19: 
Ist es möglich auch die Daten ins Archiv abzulegen, ohne das die Archiv datei geöfnet ist?

grüße Janine  :81:

[Bronko87]

Hallo,

Hab diesen Thread verfolgt und es würde mich auch sehr interessieren, ob und wie das funktioniert.
Hatte in der Vergangenheit ein ähnliches anliegen, was ich aber dann nicht mehr verfolgt habe 

Grüße 
Bronko 

[Gast 123]

Hallo

um den Code von uns Forum Ratgebern zu verstehen zeige ich euch mal den Code im Original OHNE die Set Anweisung!
Bei gleicher Funktion ist das NICHT mehr übersichtlich. Und alles ist OHNE Select, wie es der Makro Recorder aufzeichnet!

Das Kopieren sollte einfach zu verstehen sein, die For Next Schleife ist es auch. Ich prüfe ob in allen Spalten die Werte in beiden Tabellen identisch sind, und zaehle dann n + 1 dazu.  Stimmen alle Spalten überein muss n = 9 sein.  D.h., der Datensatz wurde schon kopiert. So einfach ...

Nach meinem Wissen kann man nicht in eine geschlossen Datei speichern, kann es aber nicht 100% beschwören. Freut mich auf jeden Fall das mein Vorschlag doch noch geklappt hat!  Wenn Bronko noch Fragen hat beantworte ich sie.  Bin aber nicht jeden Tag im Forum!

mfg  Gast 123

Code:

Private Sub CommandButton1_Click()
Dim WbDA As Worksheet, lzDA As Long
Dim WbEg As Worksheet, lzEg As Long
Dim j As Integer, n As Integer

 'LastZell in beiden Dateien suchen
 lzEg = Workbooks("Daten_Eingabe.xlsm").Sheets("Daten_eingabe").Cells(Rows.Count, 2).End(xlUp).Row
 lzDA = Workbooks("Daten_Archiv.xlsm").Sheets("Daten_Archiv").Cells(Rows.Count, 1).End(xlUp).Row + 1
 If lzEg = 1 Then Exit Sub
 
 'Vorptüfung ob schon kopiert wurde ...
 For j = 1 To 9
    '##Original Schreibweise ohne Set Anweisung! ##
    If Workbooks("Daten_Eingabe.xlsm").Sheets("Daten_eingabe").Cells(lzEg, j + 1) = _
      Workbooks("Daten_Archiv.xlsm").Sheets("Daten_Archiv").Cells(lzDA - 1, j) Then n = n + 1
 Next j

 If n = 9 Then MsgBox "Daten wurden bereits 1 Zeile vorher kopiert": Exit Sub
 
 'Letzte Zeile ins Archiv kopieren
 Workbooks("Daten_Eingabe.xlsm").Sheets("Daten_eingabe").Cells(lzEg, 2).Resize(1, 9).Copy
 Workbooks("Daten_Archiv.xlsm").Sheets("Daten_Archiv").Cells(lzDA, 1).PasteSpecial xlPasteValues
 Application.CutCopyMode = False
 
 'Archiv sofort speichern
 Workbooks("Daten_Archiv.xlsm").Save
End Sub

[Bronko87]

Hallo

Ich habe mal einen Code ausgegraben wo es anscheinend funktioniert.
Wie man ihn aber an Jnine Datei anpasst bin ich leider nicht fit genug 

Code:

Sub DatenExportieren()
Dim wksQuelle As Worksheet, strMaschine As String, strPersonal As String
Dim strZeit As String, strBlattname As String, strZielPfad As String
Dim varDaten As Variant, wkbZiel As Workbook, wksZiel As Worksheet, blTransponieren As Boolean

Dim dblLastRow As Double, dblLastColumn As Double
Dim lngArrBreite As Long, lngArrHoehe As Long
Dim x, y
   
   Set wksQuelle = ThisWorkbook.ActiveSheet
   With wksQuelle
       strMaschine = .Cells(3, 1)
       strPersonal = .Cells(3, 3)
       strZeit = .Cells(3, 4)
       strBlattname = .Name
 
       strBlattname = ActiveSheet.Name
       strZielPfad = ActiveWorkbook.Path & "\Archiv_" & strBlattname & ".xlsx"
       
'je nach Tabellenblatt wird der zu kopierende Bereich festgelegt:
       Select Case strBlattname
           Case Is = "HK_VP9_2Bea"
               varDaten = .Range("A5:G10")
               blTransponieren = False
           Case Else
               MsgBox "das Tabellenblatt: " & strBlattname & " muss noch angelegt werden"
       End Select
   End With

'nun gehts an das Archiv:
   strBlattname = "Archiv_" & strBlattname
   Set wkbZiel = Application.Workbooks.Open(strZielPfad)
   Set wksZiel = wkbZiel.Worksheets(strBlattname)
   
'die Position des letzten Eintrags:
   dblLastColumn = Application.WorksheetFunction.CountA(wksZiel.Rows(5))
   dblLastRow = Application.WorksheetFunction.CountA(wksZiel.Columns(4)) + 5
'die Größe des Arrays:
   lngArrHoehe = UBound(varDaten, 1)
   lngArrBreite = UBound(varDaten, 2)
'nun werden letztendlich die Daten in das Archivblatt übertragen
   With wksZiel
       If blTransponieren = False Then
            For x = dblLastRow To dblLastRow + lngArrHoehe - 1
                Cells(x, 1) = strMaschine
                Cells(x, 2) = strPersonal
                Cells(x, 3) = strZeit
            Next x
            wksZiel.Range(Cells(dblLastRow, 4), Cells(dblLastRow + lngArrHoehe - 1, dblLastColumn)) = varDaten
        Else
            For x = dblLastRow To dblLastRow + lngArrBreite - 1
                Cells(x, 1) = strMaschine
                Cells(x, 2) = strPersonal
                Cells(x, 3) = strZeit
            Next x
            wksZiel.Range(Cells(dblLastRow, 4), Cells(dblLastRow + lngArrBreite - 1, 4 + lngArrHoehe - 1)) = WorksheetFunction.Transpose(varDaten)
        End If
   End With
       Workbooks(strBlattname & ".xlsx").Close Savechanges:=True
End Sub

[schauan]

Hallöchen,

Nach meinem Wissen kann man nicht in eine geschlossen Datei speichern

Geht im Prinzip genau so wie das Holen von Daten mit ADO aus einer geschlossenen Datei. Beim Holen steht SELECT im SQL-String, beim Eintragen z.B. INSERT oder UPDATE

Für die Kritiker des Zustandes - ich streite mich nicht, ob die Datei dabei wirklich geschlossen ist. Sie ist auf jeden Fall nicht in herkömmlichem Sinne geöffnet aber ggf. temporär im Zugriff

[Jnine]

Huhu 

Also das würde mir schon völlig reichen, solange man nicht beide definitiv geöffnet haben muss.
Kann mir jemand helfen den Code an meine Mappe anzupassen?

:19:

[schauan]

Hallöchen,

hier mal der Code zum Eintrag der Daten. Ich habe die Zieldatei mal zur xlsx gemacht, da stehen ja keine codes drin.
Auf der Zieltabelle hab ich die formatierten Zeilen gelöscht, diese werden ggf. als belegte Datensätze interpretiert. Eingefügt wird immer unter den letzen vorhandenen Datensatz und es wäre vorteilhaft, wenn die zu übertragenden Datenfelder auch gefüllt sind
Läuft bei mir unter 2016 ...

Public Sub ARCHIV_SCHREIBEN()

'Variablendeklarationen 

Dim objConnection As Object, strConnection$

Dim strWBK$, strWSH$, strDaten$



'Zieldatei festlegen 

strWBK = "C:\Test\Daten_Archiv.xlsx"

'Daten aus Zeile 2 uebernehmen. Transformieren um 1D Array zu joinen 

strDaten = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(ThisWorkbook.Worksheets("Daten_Eingabe").Range("B2:J2").Value)), "','")

'Verbindung setzen 

Set objConnection = CreateObject("ADODB.Connection")

'Verbindungsstring bilden aus Treiber, Parameter, Zieldatei 

strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" & _

         "Data Source=" & strWBK & ";" & _

         "Extended Properties=""Excel 12.0;HDR=Yes;IMEX=0"""

'Verbindung oeffnen 

Call objConnection.Open(strConnection)

'Daten am Ende der Tabelle einfuegen 

Call objConnection.Execute("INSERT INTO [Daten_Archiv$A1:I100]" & _

   " VALUES ('" & strDaten & "')")

'Verbindung schliessen 

objConnection.Close

'Objekt zuruecksetzen 

Set objConnection = Nothing

End Sub

VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0

[Gast 123]

Hallo

interessant mal den Code von Schauan zu sehen, der übersteigt bei weitem mein bescheidenes Können und Wissen. 
Ich wusste nicht das man auf diese Art und Weise in Dateien reinschreiben kann. Interessant, wurde Mr. Spock dazu sagen ...

mfg gast 123

[Jnine]

Hallo Schauan,
Vielen vielen dank, hat einwandfrei funktioniert.

grüße Janine