AW: Sheet per VBA löschen
25.08.2015 10:55:15
worm77
Hallo zusammen
Ich erhalte leider gar keine Fehlermeldung...
Hab jetzt auch in nem Forum gesehen, dass man Warnmeldungen ausschalten soll, was ich auch versucht habe... aber mit dem gleichen Ergebnis.
Das Diagramm wird einfach im Sheet Masterdata erstellt.
Hier das Daten-File: https://www.herber.de/bbs/user/99814.xlsx
Hier der gesamte Code:
On Local Error Resume Next
' getsource Makro
Dim Auswahl, RetVal
Dim LastRow, NewRow As Long
Dim Zelle As Range
InputDrive = ThisWorkbook.Sheets("Mastertable").Range("E16").Value
InputDirectory = ThisWorkbook.Sheets("Mastertable").Range("E17").Value
ChDrive InputDrive
ChDir InputDirectory
ThisWorkbook.Sheets("Mastertable").Range("E30").Value = Replace(CStr(Time()), ":", "")
Calculate
ArchiveDrive = ThisWorkbook.Sheets("Mastertable").Range("E19").Value
ArchiveDirectory = ThisWorkbook.Sheets("Mastertable").Range("E20").Value
StatsDrive = ThisWorkbook.Sheets("Mastertable").Range("E22").Value
StatsDirectory = ThisWorkbook.Sheets("Mastertable").Range("E23").Value
StatsName = ThisWorkbook.Sheets("Mastertable").Range("E24").Value
' Prüfen, ob Input-Folder leer ist. Wenn leer, dann Makro abbrechen
If Dir$(InputDrive & ":\" & InputDirectory & "\*.*") = vbNullString Then
RetVal = MsgBox("Input-Verzeichnis ist leer!" & vbCrLf & vbCrLf & "Verarbeitung _
abgebrochen!", vbCritical, "Keine Daten vorhanden!")
Exit Sub
End If
'Basis-File öffnen
Application.Run "KRun_Statistik.xlsm!getbasis"
Windows("KRun_Statistik_Basis.xlsx").Activate
' Importiere alle Files in Input-Folder
ChDrive InputDrive
ChDir InputDirectory
Dim lngR As Long
Dim strFile As String, strTabName As String
strFile = Dir(InputDrive & ":\" & InputDirectory & "\" & "*.txt")
lngR = 1
With ActiveWorkbook.Sheets("TEMP")
.Range("A2:B" & Rows.Count).ClearContents
Do Until strFile = ""
lngR = lngR + 1
ActiveWorkbook.Sheets("TEMP").Cells.Clear
Sheets("TEMP").Select
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & strFile, Destination:=Range("$A$ _
1"))
.Name = "file"
.FieldNames = False
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 2
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(4, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Dim Bereich As Range
For x = 1 To Cells(Rows.Count, 1).End(xlUp).Row 'letzte Zeile
If Range("C" & x).Value = "Start" And Range("C" & x + 1).Value = "Stop" Then
Range("E" & x & ":H" & x).Value = Range("A" & x + 1 & ":D" & x + 1).Value
Range("A" & x + 1).Value = "löschen"
End If
Next x
Do
Set Bereich = Range("A:A").Find(What:="löschen", LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Bereich Is Nothing Then
Exit Do
Else: Rows(Bereich.Row).Delete Shift:=xlUp
End If
Loop
' Berechnung Runtime einfügen
Range("A1:H1").Select
Range(Selection, Selection.End(xlDown)).Select
Auswahl = Selection.Address
LastRow = Selection.Row + Selection.Rows.Count - 1
With Range("I1:I" & LastRow)
.Formula = "=F1-B1"
End With
' Daten in MASTERDATA übertragen
Range("A1:I1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("MASTERDATA").Select
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
NewRow = Selection.Rows.Count + 1
If NewRow > 1000000 Then
NewRow = 2
End If
Range("A" & NewRow).Select
ActiveSheet.Paste
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
fso.MoveFile strFile, ArchiveDrive & ":\" & ArchiveDirectory & "\"
strFile = Dir
Loop
End With
' Daten kopieren für CHART
Range("A1:I1").Select
Range(Selection, Selection.End(xlDown)).Select
Auswahl = Selection.Address
LastRow = Selection.Row + Selection.Rows.Count - 1
With Range("N1:N" & LastRow)
.Formula = "=A1"
End With
With Range("O1:O" & LastRow)
.Formula = "=D1"
End With
With Range("P2:P" & LastRow)
.Formula = "=CONCATENATE(TEXT(N2,""tt.MM.jjjj""),"" "",O2)" '