Makro Batchverarbeitung

Hallo Zusammen
Ich habe mit dem Recorder ein Makro aufgenommen. Ausser dass es sehr langsam rechnet funktioniert es wie ich will.
Nun würde ich das Makro gerne so ausbauen, dass ich mehrere Files gleichzeitig bearbeiten kann und dass es mir als Dateien mit z.B fortlaufender Nummerierung generiert.
Gerne darf natürlich auch das Makro vereinfacht werden.
Was das Makro eigentlich macht ist Werte auf Sekundenbasis in Werte auf 5-Min-Basis umrechnet und in einem separaten File speichert.
Unten der Code vom Makro
Herzlichen Dank!!

Sub Obergrenze()
' Obergrenze Makro
Range("F2").Select
ActiveCell.FormulaR1C1 = "=CEILING(RC[-4],""0:05"")"
Range("F2").Select
Selection.AutoFill Destination:=Range("F2:F36001")
Range("F2:F36001").Select
Columns("F:F").Select
Selection.Copy
Columns("G:G").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Range("$G$1:$G$36001").RemoveDuplicates Columns:=1, Header:= _
xlNo
Columns("F:F").Select
Columns("B:B").ColumnWidth = 24.22
Columns("B:B").Select
Selection.Copy
Columns("F:G").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("H2").Select
ActiveCell.FormulaR1C1 = "=AVERAGEIFS(C[-5],C[-2],RC[-1])"
Range("H2").Select
Selection.AutoFill Destination:=Range("H2:H36001")
Range("H2:H36001").Select
Range("J13").Select
Range("G2:H2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("C3").Select
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "5min_.xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
Range("I102").Select
ActiveWindow.SmallScroll Down:=-21
Range("I82").Select
Range("H2").Select
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Obergrenze() Application.ScreenUpdating = False Range("F2:F36001").FormulaR1C1 = "=CEILING(RC[-4],""0:05"")" Columns(6).Copy Columns(7).PasteSpecial Paste:=xlPasteValues Columns(7).RemoveDuplicates Columns:=1, Header:=xlNo Columns(2).ColumnWidth = 24.22 Columns(2).Copy Columns(6).Resize(, 1).PasteSpecial Paste:=xlPasteValues Range("H2:H36001").FormulaR1C1 = "=AVERAGEIFS(C[-5],C[-2],RC[-1])" Range("H2:G" & Cells(Rows.Count, 7).End(xlUp).Row).Copy Workbooks.Add Range("A1").PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "5min_.xlsx", _ FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False ActiveWindow.Close Range("H2").Select End Sub

Sub Obergrenze() Dim LR As Long, TB, WB Set TB = ActiveSheet With TB LR = 36001 'oder LR = .Cells(.Rows.Count, "B").End(xlUp).Row .Range("F2").Resize(LR, 1).FormulaR1C1 = "=CEILING(RC[-4],""0:05"")" .Range("G2").Resize(LR, 1).Value = .Range("F2").Resize(LR, 1).Value .Range("G2").Resize(LR, 1).RemoveDuplicates Columns:=1, Header:=xlNo .Columns("B:B").ColumnWidth = 24.22 .Columns("B:B").Copy .Columns("F:G").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False .Range("H2").Resize(LR, 1).FormulaR1C1 = "=AVERAGEIFS(C[-5],C[-2],RC[-1])" LR = .Cells(.Rows.Count, "G").End(xlUp).Row Set WB = Workbooks.Add WB.Sheets(1).Cells(2, 1).Resize(LR, 2).Value = .Range("G2").Resize(LR, 2).Value WB.SaveAs Filename:=ThisWorkbook.Path & "\" & "5min_.xlsx" _ , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False ActiveWindow.Close .Range("H2").Select End With End Sub

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread