AW: Zellensprung
15.02.2008 06:31:41
fcs
Hallo Christian,
ganz genau konnte ich es nicht testen wg. alter Excelversion, die Probleme mit der Querrytable hat. Da du aus dem Output-Text-File die Daten mit festen Spaltenbreiten ausliest könnte es daran liegen, dass die Zeilen im Textfile nicht alle gleich lang sind.
Deshalb lasse ich ich die per InputBox eingegebene Zahl, jetzt in einem bestimmten Format in das Outputfile schreiben. Das Format muss du ggf. anpassen (z.B. "0000.000"), wobei für alle Dezimalstellen ein Zeichen (führende Nullen oder Leerzeichen) ins Textfile geschrieben werden muss. Evtl. ist bei Eingabe von Dezimalzahlen auch die Funktion CDbl statt Val die günstigere für die Umwandlung der InputBox-Eingabe in eine Zahl. Abhängig von der Zeichenzahl im zahlenformat muss du ggf. auch die Zahl der Zeichen in einer Zeile anpssen (z.Zt 77 im Code)
Für das Einfügen der Querry-Table hab ich 2 zusätzliche Spalten definiert für Text "Konzentration" und die eingegebene Zahl. ggf. muss du entsprechend dem Zahlenformat für die letzte Spalte die Zeichenzahl (z.Zt. 8) im Code anpassen.
Gruß
Franz
Sub MergeFiles(SourceFolder As String, OutputFile As String)
'Zusammenfügen nummerierter .txt Dateien in aufsteigender Richtung
Dim i As Integer
Dim Textzeile As String
Dim Dateiname As String
Dim numOut As Long
Dim numIN As Long
Dim strNum As String, n As Long
numOut = FreeFile
Open SourceFolder & OutputFile For Output As #numOut
Dateiname = Dir(SourceFolder & "*.txt")
Do While Not Dateiname = ""
If Dateiname OutputFile Then
n = 0
numIN = FreeFile
strNum = InputBox("Aktuelle Datei: " & Dateiname & Chr(13) & Chr(10) _
& "Bitte Anzahl Sporen oder DNA-Konzentration erfassen:", "Zusatz", "")
Open SourceFolder & Dateiname For Input As #numIN 'Öffne gefundene Datei
Do While Not EOF(numIN) 'Schleife bis Dateiende.
Line Input #numIN, Textzeile 'Zeile in Variable einlesen.
n = n + 1
'##### angepasst Anfang
If n = 3 Then
'einfügen in Zeile 3 ' Box erfassen
Textzeile = Textzeile & Chr(32) & "Konzentration "
Textzeile = Textzeile & Chr(32) & Format(Val(strNum), "0000000")
Else
'Zeile mit Leerzeichen auffüllen
Textzeile = Textzeile & VBA.Space(77 - Len(Textzeile))
End If
'##### angepasst Ende
Print #numOut, Textzeile 'Ausgabe in Datei.
Loop
Close #numIN
End If
Dateiname = Dir
Loop
Close #numOut
End Sub
Sub Import_TXT(Filename As String, Position As String, DatenBereich As String)
' B1 B:H
Range(DatenBereich).Select
Selection.ClearContents
MsgBox "DataRange: " & DatenBereich & " deleted!"
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & Filename, _
Destination:=Range(Position))
.Name = Filename
.FieldNames = True '### ggf. auf False setzen
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlFixedWidth
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1) '##### fcs angepasst
.TextFileFixedColumnWidths = Array(6, 12, 9, 9, 9, 9, 15, 8) '##### fcs angepasst
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub