VBA - Messwerte per Makro in Protokolle kopieren

[skafo]

Hallo,

ich habe leider recht wenig (also gar keine) Ahnung von VBA, bräuchte aber dringend für die Arbeit ein Makro und habe leider nicht genug Zeit mich einzuarbeiten.

Die Problemstellung ist folgende:
Eine Koordinatenmessmaschine gibt die Messwerte einer Serienmessung von 10 Teilen in eine Sammeldatei aus. Dies ist eine mit Tab getrennte .txt und wird mit folgendem Code ausgelesen

Code:

Sub merge_öffnen()
'
' Sammeldatei merge__chr.txt öffnen
'
    Workbooks.OpenText Filename:= _
        "S:\xxx\xxx\merge__chr.txt", _
        Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
        xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
        Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _
        Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), _
        Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15 _
        , 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 1), _
        Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), Array(27, 1), Array( _
        28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array(33, 1), Array(34, 1), _
        Array(35, 1), Array(36, 1), Array(37, 1), Array(38, 1), Array(39, 1), Array(40, 1), Array( _
        41, 1), Array(42, 1), Array(43, 1), Array(44, 1), Array(45, 1), Array(46, 1)), _
        DecimalSeparator:=".", ThousandsSeparator:=",", TrailingMinusNumbers:= _
        True
        
End Sub

Nach dem Einlesen sollen bestimmte Felder/Bereiche kopiert und in vorgefertigte Excel Protokolle eingefügt werden. Es handelt sich um ca. 100 verschiedene Protokolle, die zwar vom Layout her gleich sind, sich in Dateiname und Spaltenanzahl aber unterscheiden. Die unterschiedliche Spaltenanzahl ist dann ja aber nur eine Anpassungssache.

Jemand hat mir diesen Code zum kopieren und einfügen gegeben, allerdings habe ich damit noch ein paar Probleme:

Code:

Public Function copyData1()
   Dim fd As FileDialog
   Dim file As String
   Dim objApp, objWBSource, objWBTarget, objWSSource, objWSTarget As Object

   Set fd = Application.FileDialog(msoFileDialogOpen)
   With fd
      'Mehrfachauswahl verbieten
      .AllowMultiSelect = False
      .Title = "Zieldatei wählen..."
      'Filter löschen
      .Filters.Clear
      'Neue Filter hinzufügen
      .Filters.Add "Exceldateien", "*.xlsx; *.xlsm", 1
      'Prüfen ob Abgebrochen wurde
      If .Show = -1 Then
         file = .SelectedItems(1)
      Else
         Exit Function
      End If
   End With

    'Datei öffnen
    Set objApp = CreateObject("Excel.Application")
    Set objWBTarget = objApp.Workbooks.Open(file)

    Set objWBSource = ActiveWorkbook
    
    'Zieltabelle auswählen
    Set objWSTarget = objWBTarget.Worksheets("Prüfprotokoll")
    'Quelltabelle wählen 1.Zeile für eigenen Namen - 2. Zeile für aktive Tabelle
    'Set objWSSource = objWBSource.Worksheets("")
    Set objWSSource = ActiveSheet
    
    'Zellen Kopieren - Entweder einen ganzen Bereich z.B. Range("A1:A5") oder eine einzelne Zelle
    'z.B. Range("A1") oder eben über den Namen einer Zelle oder Zellbereichs Range("CELLNAME")
    'ggf. hier eine Schleife beginnen oder die nächsten Zeilen für jeden Datensatz einzeln
    'aufrufen
    'BEGIN COPY-PASTE-BLOCK
        'Quellworkbook aktivieren
        objWSSource.Activate
        Application.CutCopyMode = False
        objWSSource.Range("F2").Copy

        'und Einfügen an die passende Stelle
        objWSTarget.Range("B28").PasteSpecial
    'END COPY-PASTE-BLOCK
    
   'Ziel speichern und schließen
   objWBTarget.Save
   objWBTarget.Close

   'Zurück zu Quelldatei wechseln
   objWBSource.Activate
    
   'Speicher freigeben
   objApp.Quit
    
   Set objWSTarget = Nothing
   Set objWSSource = Nothing
   Set objWBTarget = Nothing
   Set objWBSource = Nothing
   Set objApp = Nothing
   Set fd = Nothing
End Function

Das Hauptproblem ist, dass die Werte nicht einfach als Text kopiert werden sondern anscheinend als "Objekt" (sieht dann aus wie ein Bild oder ne Textbox oder sowas).
Eigentlich sollte die Quelldatei geschlossen werden und die Zieldatei sollte geöffnet und aktiviert werden. Wenn ich jedoch objWBTarget.Activate benutze läuft irgendwas im Hintergrund ab, ein Prozess "Excel" im Taskmanager entsteht und die Datei wird gesperrt, bis ich den Prozess kille.

Also nochmal zusammengefasst sollen die Werte kopiert werden, dann die Quelldatei geschlossen werden und die Zieldatei geöffnet werden.

Mfg

[Kuwer]

Hallo,

teste es mal damit:

Code:

Public Sub CopyData1()
  Dim objWSSource As Worksheet, objWSTarget As Worksheet
  Dim strFile As String

  strFile = Application.GetOpenFilename("Exceldateien (*.xlsx;*.xlsm),*.xlsx;*.xlsm", , "Zieldatei wählen...")
  If Not CVar(strFile) = False Then
    Set objWSSource = ActiveSheet
    Application.ScreenUpdating = False
    'Datei öffnen und Zieltabelle auswählen
    Set objWSTarget = Workbooks.Open(strFile).Worksheets("Prüfprotokoll")
    'Zellen Kopieren - Entweder einen ganzen Bereich z.B. Range("A1:A5") oder eine einzelne Zelle
    'z.B. Range("A1") oder eben über den Namen einer Zelle oder Zellbereichs Range("CELLNAME")
    'ggf. hier eine Schleife beginnen oder die nächsten Zeilen für jeden Datensatz einzeln
    'aufrufen
    
    'BEGIN COPY-PASTE-BLOCK
    objWSSource.Range("F2").Copy objWSTarget.Range("B28")
    'END COPY-PASTE-BLOCK
    
    'Ziel speichern und schließen
    objWSTarget.Parent.Close True
    Application.ScreenUpdating = True
  Else
    MsgBox "Es wurde keine Datei ausgewählt."
  End If
End Sub

Gruß Uwe

[skafo]

Danke, so funktionierts :19:
Allerdings sollte die Quelldatei und nicht die Zieldatei geschlossen werden, aber das hab ich so wies aussieht hingekriegt.

Danke nochmal.

[skafo]

Ach eine Sache noch, wie kann ich beeinflussen wie viele Stellen nach dem Komma kopiert werden (mit/ohne Runden)?

[skafo]

Achso und bei Abbruch, also wenn keine Datei ausgewählt wurde, sollte die Quelldatei wieder geschlossen werden.

[Kuwer]

Hallo skafo,

ich habe das jetzt in einem Makro zusammengefasst:

Code:

Sub Merge_Oeffnen_Und_Uebertragen()
  Dim objWSSource As Worksheet, objWSTarget As Worksheet
  Dim strFile As String
    
  'Bilschirmaktualisierung ausschalten
  Application.ScreenUpdating = False

'Sammeldatei merge__chr.txt öffnen
  Set objWSSource = Workbooks.OpenText(Filename:="S:\xxx\xxx\merge__chr.txt", _
      Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
      xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
      Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _
      Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), _
      Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15 _
      , 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 1), _
      Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), Array(27, 1), Array( _
      28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array(33, 1), Array(34, 1), _
      Array(35, 1), Array(36, 1), Array(37, 1), Array(38, 1), Array(39, 1), Array(40, 1), Array( _
      41, 1), Array(42, 1), Array(43, 1), Array(44, 1), Array(45, 1), Array(46, 1)), _
      DecimalSeparator:=".", ThousandsSeparator:=",", TrailingMinusNumbers:=True).Worksheets(1)
      
  'Zieldatei auswählen
  strFile = Application.GetOpenFilename("Exceldateien (*.xlsx;*.xlsm),*.xlsx;*.xlsm", , "Zieldatei wählen...")
  
  'wenn Zieldatei wirklich ausgewählt wurde
  If Not CVar(strFile) = False Then
    'ZielDatei öffnen und Zieltabelle auswählen
    Set objWSTarget = Workbooks.Open(strFile).Worksheets("Prüfprotokoll")
    
    'Zellen Kopieren - Entweder einen ganzen Bereich z.B. Range("A1:A5") oder eine einzelne Zelle
    'z.B. Range("A1") oder eben über den Namen einer Zelle oder Zellbereichs Range("CELLNAME")
    'ggf. hier eine Schleife beginnen oder die nächsten Zeilen für jeden Datensatz einzeln
    'aufrufen
    
    'WERTE-UEBERTRAG-BLOCK
    objWSTarget.Range("B28").Value = Round(objWSSource.Range("F2").Value, 2) 'gerundet auf 2 Nachkommastellen
    'ENDE WERTE-UEBERTRAG-BLOCK
  End If
  
  'Quelldatei ohne Speichern schließen
  objWSSource.Parent.Close False
  
  'Bilschirmaktualisierung einschalten
  Application.ScreenUpdating = True
End Sub

Gruß Uwe

[skafo]

Vielen Dank. Jetzt klappt alles soweit.