Hallo alle zusammen,

Ich muss Messwerte die in eine txt geschrieben werden aus dieser auslesen und in eine Excel Übersicht einlesen. Bisher habe ich das Makro das ich habe immer aus einer extra Excel Tabelle gestartet, da ich mehrere Schaltflächen für die jeweils zugehörige Anzahl von Messmerkmalen gebraucht habe.

Nun muss ich eine Reihenmessung machen, 88 Teile mit jeweils einem (und dem gleichen) Messmerkmal. Die Ergebnisse werden wieder in eine txt geschrieben und sollen von dort Ausgelesen und in eine Übersicht in Excel geschrieben werden. Diese stellt die Palette auf der die Teile liegen dar und jeder Platz soll sich, je nach dem ob der Messwert i.O. oder nicht ist, rot oder grün Färben.

Das mit den farben ist ja kein Problem, und woher die Daten kommen, wo sie ausgelesen werden sollen, und wo sie reingeschrieben werden sollen hab ich alles hingekriegt. Das einzige das ich jetzt noch brauche und nicht selber hinkriege ist, dass der Button zum ausführen des Makros im selben Blatt sein soll wie die Übersicht.

Hier mal wie es aussieht und der original Code dazu, wäre nett wenn ihn mir jemand so abändern könnte, dass die Daten aus der txt ausgelesen und in die Übersicht reingeschrieben werden.

http://i65.tinypic.com/lit90.jpg

Sub eineSpalte()
   merge_öffnen
   CopyData1
End Sub

Sub merge_öffnen()
'
' Sammeldatei merge__chr.txt öffnen
   Workbooks.OpenText Filename:= _
       "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

Public Sub CopyData1() '1 Merkmal

 Dim objWSSource As Worksheet, objWSTarget As Worksheet
 Dim strFile As String
 
 ChDrive ("S:\")
 ChDir ("xxx\Vorlagen\")

 strFile = Application.GetOpenFilename("Exceldateien (*.xlsx;*.xlsm;*.xls),*.xlsx;*.xlsm;*.xls", , "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("Auswertung")
   '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
   
   'Zeile 1
   objWSTarget.Range("A1:K1").Value = objWSSource.Range("F2:F12").Value
   
   'Zeile 2
   objWSTarget.Range("A2:K2").Value = objWSSource.Range("F13:F23").Value
   
   'Zeile 3
   objWSTarget.Range("A3:K3").Value = objWSSource.Range("F24:F34").Value
   
   'Zeile 4
   objWSTarget.Range("A4:K4").Value = objWSSource.Range("F35:F45").Value
   
   'Zeile 5
   objWSTarget.Range("A5:K5").Value = objWSSource.Range("F46:F56").Value
   
   'Zeile 6
   objWSTarget.Range("A6:K6").Value = objWSSource.Range("F57:F67").Value
   
   'Zeile 7
   objWSTarget.Range("A7:K7").Value = objWSSource.Range("F68:F78").Value
   
   'Zeile 8
   objWSTarget.Range("A8:K8").Value = objWSSource.Range("F79:F89").Value
   
   'END COPY-PASTE-BLOCK
   
   'Quelldatei ohne Speichern schließen
   objWSSource.Parent.Close False
 
   'Bilschirmaktualisierung einschalten
   Application.ScreenUpdating = True
   
   'Runden
   Set objWSTarget = ActiveSheet
   For Each cell In [A1:K8]
       cell.Value = WorksheetFunction.Round(cell.Value, 3)
   Next cell
   
   'Ordner Tabellen leeren
   Kill "xxx\*.txt"
   
 Else
   MsgBox "Es wurde keine Datei ausgewählt."
   Set objWSSource = ActiveSheet
   objWSSource.Parent.Close
 End If
End Sub