Probleme beim abspeichern und Format
01.09.2016 13:42:06
Tim
ich hatte das Makro mal mit einem freundlichen Helfer dieses Forums begonnen und es lief auch alles, aber im täglichen Gebrauch haben sich dann doch Probleme ergeben.
1. Das Makro soll die zusammengeführte Datei automatisch unter dem Namen der .xls Datei an einem festgelegten Ort speichern
2. Wenn ich manuell abspeicher hat die zusammengeführte Datei nachher einen Fehler und lässt sich nicht mehr öffnen...
Die kursiv geschriebenen Teile sind nur Bearbeitungen der Dateien und sollten eigentlich nicht zu Problemen führen.
Das Makro führt eine .log und eine .xls-Datei zusammen in eine als kurze Erklärung
Sub Schaltfläche1_Klicken()
Dim WB As Workbook
Dim iXLS As String
Dim iLOG As String
Dim filename As String
Dim pfad As String
sFiles = Application.GetOpenFilename("alle Dateien (*.*), *.*", MultiSelect:=True)
If Not IsArray(sFiles) Then Exit Sub
If UBound(sFiles) > 2 Then MsgBox "zu viele Dateien": Exit Sub
For i = 1 To UBound(sFiles)
'Debug.Print sFiles(i)
If InStr(sFiles(i), ".xls") > 0 Then iXLS = sFiles(i)
If InStr(sFiles(i), ".LOG") > 0 Then iLOG = sFiles(i)
Next i
Set WB = Workbooks.Open(iXLS)
WB.Sheets.Add , WB.Sheets(Sheets.Count), , iLOG
' Log-Bearbeitung
Dim rng As Long
Range("A2").Select
ActiveCell.FormulaR1C1 = _
" Measuring length: 1.010 meter" & Chr(13) & "" & Chr(10) & " PC-time: Mon Aug 01 11: _
16:14 2016"
Range("A1").Select
ActiveCell.FormulaR1C1 = _
" Instrument serial number: 2616" & Chr(13) & "" & Chr(10) & " LineNo-GasName-Unit: 1- _
O2-% " & Chr(10) & " Measuring length: 1.010 meter" & Chr(10) & " PC-time: Mon Aug 01 11:16:14 2016"
Range("A3").Select
ActiveCell.FormulaR1C1 = _
" sec = seconds after midnight (PC-time)" & Chr(13) & "" & Chr(10) & " GasName-LineNo/i/ _
a/s = gas concentration inst/avg/std"
Range("A1").Select
ActiveCell.FormulaR1C1 = _
" Instrument serial number: 2616" & Chr(13) & "" & Chr(10) & " LineNo-GasName-Unit: 1- _
O2-% " & Chr(10) & " Measuring length: 1.010 meter" & Chr(10) & " PC-time: Mon Aug 01 11:16:14 2016" & Chr(10) & " sec = seconds after midnight (PC-time)" & Chr(10) & " GasName-LineNo/i/a/s = gas concentration inst/avg/std"
Range("A4").Select
ActiveCell.FormulaR1C1 = _
" LineNo-lw/lp/la = line width/line position/line amplitude" & Chr(13) & "" & Chr(10) & _
" sts = instrument status: SLEEPMODE/STARTUP/OK/WARNING/ERROR = -4/-1/0/1/2"
Range("A1").Select
ActiveCell.FormulaR1C1 = _
" Instrument serial number: 2616" & Chr(13) & "" & Chr(10) & " LineNo-GasName-Unit: 1- _
O2-% " & Chr(10) & " Measuring length: 1.010 meter" & Chr(10) & " PC-time: Mon Aug 01 11:16:14 2016" & Chr(10) & " sec = seconds after midnight (PC-time)" & Chr(10) & " GasName-LineNo/i/a/s = gas concentration inst/avg/std" & Chr(10) & " LineNo-lw/lp/la = line width/line position/line amplitude" & Chr(10) & " sts = instrument status: SLEEPMODE/STARTUP/OK/WARNING/ERROR = -4/-1/0/1/2"
Range("A5").Select
ActiveCell.FormulaR1C1 = " mode = measurement mode: OK/ZERO/SPAN = 0/1/2" & Chr(13) & "" & _
Chr(10) & " 1"
Range("A1").Select
ActiveCell.FormulaR1C1 = _
" Instrument serial number: 2616" & Chr(13) & "" & Chr(10) & " LineNo-GasName-Unit: 1- _
O2-% " & Chr(10) & " Measuring length: 1.010 meter" & Chr(10) & " PC-time: Mon Aug 01 11:16:14 2016" & Chr(10) & " sec = seconds after midnight (PC-time)" & Chr(10) & " GasName-LineNo/i/a/s = gas concentration inst/avg/std" & Chr(10) & " LineNo-lw/lp/la = line width/line position/line amplitude" & Chr(10) & " sts = instrument status: SLEEPMODE/STARTUP/OK/WARNING/ERROR = -4/-1/0/1/2" & Chr(10) & " mode = " & _
" mode = measurement mode: OK/ZERO/SPAN = 0/1/2" & Chr(13) & "" & Chr(10) & " 1"
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("2:5").Select
Selection.Delete Shift:=xlUp
Range("A1:X1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Rows("1:1").RowHeight = 160.5
Range("A2").Select
ActiveCell.FormulaR1C1 = "time"
Range("A3").Select
ActiveCell.FormulaR1C1 = "=RC[1]/86400"
Range("A3").Select
Selection.NumberFormat = "[$-F400]h:mm:ss AM/PM"
rng = Range("B65526").End(xlUp).Row
Range("A3").Select
Selection.AutoFill Destination:=Range(Cells(3, 1), Cells(rng, 1)), Type:=xlFillDefault
ActiveSheet.Previous.Select
' xls-Bearbeitung
Columns("A:A").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("G:G").EntireColumn.AutoFit
Range("B3:H3").Select
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("A7").Select
Selection.Delete Shift:=xlToLeft
' Speichern
filename = Replace(WB.Name, ".xls", "")
MsgBox filename
' WB.SaveAs "D:\Eigene Dateien\" & filename & ".xlsx"
pfad = "D:\Eigene Dateien\" & filename & ".xls"
MsgBox pfad
WB.SaveAs pfad
End
Sub
Ich hoffe ihr könnt mich noch einmal unterstützen. Produziere im Moment nur mehr neue Fehler _
als Lösungen...
Vielen Dank
Tim
