Copy - Paste
12.08.2004 18:39:39
Rosenwasser
Kann jemand mein code (wass langsam lauft) etwas eleganter anpassen?
CODE:
Sub Omzetten_van_L1()
Application.StatusBar = "Export L1.gbm to L1.xls..."
Application.ScreenUpdating = False
Workbooks.OpenText Filename:=Range("z1") & "\L1*.gbm", Origin:=xlWindows, StartRow _
:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _
, Space:=False, Other:=True, OtherChar:="_", FieldInfo:=Array(Array(1, 1 _
), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1))
z = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Rows(z & ":" & z).Delete
Dim lastCell As Range
Dim intDifferenz As Integer
Dim iRow As Integer
Dim intSteps As Integer
Dim i As Integer
Set lastCell = Cells(Rows.Count, 2).End(xlUp)
iRow = lastCell.Row
'Alle Datumreihen löschen
Do While IsDate(Cells(iRow, 2))
Rows(iRow).Delete
iRow = iRow - 1
Loop
'Fehlende Reihen bis '0' anfügen
intDifferenz = Cells(iRow, 2) - Cells(iRow - 1, 2)
intSteps = Abs(Cells(iRow, 2) / intDifferenz)
For i = 1 To intSteps
Cells(iRow + i, 2) = Cells(iRow + i - 1, 2) + intDifferenz
Next
Call Omzetten_van_punt
Cells.Select
Workbooks.Open Filename:="C:\GBM\Gbm-Data.Xls"
Sheets(" L1 ").Select
Range("A1").Select
Cells.Select
ActiveSheet.Paste
Range("A1").Select
ActiveWorkbook.Save
ActiveWorkbook.Close
Range("E2").Select
Range("E2").Cut Destination:=Range("D2")
ActiveWorkbook.SaveAs Filename:="C:\GBM\L1.xls", FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
Columns("B:D").Select
Selection.Copy
Windows("GBM.xls").Activate
Sheets("Data").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("C2").Select
Selection.Copy
Range("X1").Select
ActiveSheet.Paste
Range("A3:C2000").Select
Selection.Sort Key1:=Range("A3"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("A3").Select
Windows("L1.xls").Activate
ActiveWorkbook.Close
Kill "C:\GBM\L1.xls"
Range("A1").Select
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
Danke