AW: schnellerer Durchlauf
03.11.2005 13:10:23
lexika
Hi,
das Makro ist teils hier aus dem forum und teils mit dem recoder aufgenommen.
Public
Sub Sensor1_alle()
ActiveSheet.Range("F20:I65536").ClearContents
Range("A10").Select
'Datei einlesen
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;D:\excel\Neuer Ordner\Neu\1\versuch.csv" _
, Destination:=Range("F20"))
.Name = "Sensor_1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = xlWindows
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierNone
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1)
.TextFileDecimalSeparator = "."
.Refresh BackgroundQuery:=False
End With
Range("F:F,I:I").Select
Range("I1").Activate
Selection.Replace What:="""", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByColumns, MatchCase:=False
Range("G21:G65000").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
Range("F20").Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:="Datum(dd-mmm-yy)"
Range("F21:F65500").Select
Selection.EntireRow.Delete
Selection.AutoFilter Field:=1
Selection.AutoFilter
Range("A10").Select
Dim lx&
'Spaltenenden suchen
With Sheets("Sensor 1")
lx = .Cells(.Rows.Count, 8).End(xlUp).Row
End With
Range("AC21").Select
ActiveCell.FormulaR1C1 = "=VALUE(RC[-23])"
Range("AC21").Select
Selection.Copy
Range("AC22:AC" & lx).Select
ActiveSheet.Paste
Columns("AC:AC").Select
Selection.NumberFormat = "d-mmm-yy"
Range("AC21:AC" & lx).Select
Selection.Copy
Range("F21").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
True, Transpose:=False
Range("F:F").Select
Selection.NumberFormat = "d-mmm-yy"
Range("F20").Select
Range("F20").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Range("E20").Select
Range("F21:I65536").Select
Selection.Sort Key1:=Range("F21"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("E20").Select
Range("I21:I33345").Select
Application.CutCopyMode = False
Selection.Copy
Range("R21").Select
ActiveSheet.Paste
Range("H21:H33345").Select
Application.CutCopyMode = False
Selection.Copy
Range("Q21").Select
ActiveSheet.Paste
Range("N20").Select
Application.CutCopyMode = False
Selection.Copy
Range("R21:R33345").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlDivide, SkipBlanks:= _
False, Transpose:=False
Range("A10").Select
Dim ly&
Dim maxwert_temp, maxwert_feuchte
Dim minwert_temp, minwert_feuchte
Dim mittelwert_temp, mittelwert_feuchte
Dim ERow
'Spaltenenden suchen
With Sheets("Sensor 1")
ly = .Cells(.Rows.Count, 8).End(xlUp).Row
End With
If ly <= 2160 Then
ERow = 2
Else
ERow = ly - 2159
End If
maxwert_temp = WorksheetFunction.Max(Sheets("Sensor 1").Range("H" & ERow & ":H" & ly))
Cells(21, 21) = maxwert_temp
maxwert_feuchte = WorksheetFunction.Max(Sheets("Sensor 1").Range("I" & ERow & ":I" & ly))
Cells(21, 23) = maxwert_feuchte
minwert_temp = WorksheetFunction.Min(Sheets("Sensor 1").Range("H" & ERow & ":H" & ly))
Cells(21, 22) = minwert_temp
minwert_feuchte = WorksheetFunction.Min(Sheets("Sensor 1").Range("I" & ERow & ":I" & ly))
Cells(21, 24) = minwert_feuchte
mittelwert_temp = WorksheetFunction.Average(Sheets("Sensor 1").Range("H" & ERow & ":H" & ly))
Cells(21, 19) = mittelwert_temp
mittelwert_feuchte = WorksheetFunction.Average(Sheets("Sensor 1").Range("I" & ERow & ":I" & ly))
Cells(21, 20) = mittelwert_feuchte
Range("Y20").Select
ActiveCell.FormulaR1C1 = _
"=TEXT(RC[-19],""[$-407]T. MMM JJ;@"")&"",""&TEXT(RC[-18],""hh:mm:ss"")&"",""&SUBSTITUTE(RC[-17],"","",""."")&"",""&SUBSTITUTE(RC[-16],"","",""."")"
Selection.Copy
Range("Y21:Y" & ly).Select
ActiveSheet.Paste
Columns("R:R").Select
Selection.Replace What:="0", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByColumns, MatchCase:=False
Range("F18").Select
ChDir "D:\excel\Neuer Ordner\Neu\1"
Workbooks.Open Filename:="D:\excel\Neuer Ordner\Neu\1\versuch.csv"
Columns("A:A").Select
Selection.ClearContents
Windows("test.xls").Activate
Range("Y20:Y32020").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
ActiveWindow.WindowState = xlMinimized
Range("A1").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
True, Transpose:=False
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:="D:\excel\Neuer Ordner\Neu\1\versuch.csv", _
FileFormat:=xlCSV, CreateBackup:=False
ActiveWindow.Close
Application.DisplayAlerts = True
ActiveWindow.WindowState = xlMaximized
If Not Rows(2200).Hidden Then
If Sheets("Sensor 1").Cells(2200, 6).Value <> "" Then
Dim CommandButton6
Sheets("Sensor 1").CommandButton6.Enabled = True
End If
End If
Columns("A:A").ColumnWidth = 17
Columns("B:B").ColumnWidth = 13
Columns("C:C").ColumnWidth = 13
Columns("D:D").ColumnWidth = 10
Columns("E:E").ColumnWidth = 5
Columns("F:F").ColumnWidth = 17
Columns("G:G").ColumnWidth = 13
Columns("H:H").ColumnWidth = 13
Columns("I:I").ColumnWidth = 10
Columns("J:J").ColumnWidth = 19
Range("E20").Select
If Not Rows(32000).Hidden Then
If Sheets("Sensor 1").Cells(32000, 6).Value <> "" Then
Dim Quelle As String, Ziel As String
Quelle = "D:\excel\Neuer Ordner\Neu\1\versuch.csv"
Ziel = "D:\excel\Neuer Ordner\Neu\Archiv\" & "Sensor1_bis_" & Sheets("Sensor 1").Cells(32000, 6).Value & ".csv"
FileCopy Quelle, Ziel
MsgBox "Sensordaten wurden archiviert"
Kill "D:\excel\Neuer Ordner\Neu\1\versuch.csv"
End If
End If
End Sub
Danke