AW: kleiner VBA Code zusammengewürfelt :-(
05.05.2009 12:00:29
Drusilla
so gehts, vielen dank schonmal!!
dürfte ich noch eine zusatzfrage anhängen?
ich habe den code noch etwas erweitert, weil ich verschiedene kopien anfertigen möchte, die sich auf verschiedene zeitspannen beziehen. doch da habe ich das problem, dass die zweite kopie aus der ersten kopie und nicht dem ursprungsfile angefertigt wird. wisst ihr, was ich meine? also das ursprungsfile ist 24h und daraus generiere ich ein file, das nur die daten von 18-23 uhr enthält. will ich jetzt aber noch eine kopie anfertigen, die die daten von 6-17 uhr enthält, ist die kopie komplett leer... wie könnte man das problem lösen?
Option Explicit
Sub Output_Standart()
Dim Ws As Worksheet
Dim lngzeile As Long
Dim strDatNam As String
Application.ScreenUpdating = False
With ActiveWorkbook
'Sicherheitsabfrage:
If MsgBox("Soll die Datei " & .Name & " bearbeitet werden?", vbYesNo) = vbNo Then
GoTo Ende
End If
For Each Ws In .Worksheets
With Ws
If .Name "Titelblatt" Then 'Titelblatt übergehen
'Fixierung aufheben:
.Activate
ActiveWindow.FreezePanes = False
'Spalten einblenden
.Range(.Cells(1, 1), .Cells(1, Columns.Count)).EntireColumn.Hidden = False
'Zeilen einblenden:
.Range(.Cells(1, 1), .Cells(Rows.Count, 1)).EntireRow.Hidden = False
'Mittelwert ausgeben:
lngzeile = .Cells(.Rows.Count, "J").End(xlUp).Row
.Cells(lngzeile + 2, "J").Value = _
Application.WorksheetFunction.Average(.Range(.Cells(4, "J"), .Cells( _
lngzeile, "J")))
'Zeilen löschen wenn in Spalte J (Kosten) der Zellwert = 0 ist (löscht auch _
Leerzeilen)
For lngzeile = .Cells(.Rows.Count, "J").End(xlUp).Row To 4 Step -1
If .Cells(lngzeile, "J").Value = 0 Then
.Rows(lngzeile).Delete
End If
Next
'Das Datenblatt "SF 1" in "SF1" umbenennen:
If .Name = "SF 1" Then .Name = "SF1"
End If
End With
Next 'nächstes Tabellenblatt
'Speichern
ActiveWorkbook.SaveAs Filename:="24h.xls"
Set Ws = Nothing
'Kopie anfertigen: 18.00-23.00
strDatNam = Application.GetSaveAsFilename("1800_2300", "Excel-Files (*.xls),*.xls,Alle _
Dateien (*.*),*.*")
If strDatNam = "Falsch" Then
MsgBox "Das Programm wird beendet!"
GoTo Ende
End If
.SaveAs Filename:=strDatNam
End With
With Workbooks(Split(strDatNam, "\")(UBound(Split(strDatNam, "\"))))
For Each Ws In .Worksheets
'Zeilen löschen, die in M Zeiten außerhalb von 18:00:00 bis 23:00:00 haben
With Ws
If .Name "Titelblatt" Then 'Titelblatt übergehen
For lngzeile = .Cells(.Rows.Count, "M").End(xlUp).Row To 3 Step -1
If .Cells(lngzeile, "M").Value _
CDate("23:00:00") Then
.Rows(lngzeile).Delete
End If
Next
End If
End With
Next 'nächstes Tabellenblatt
.Save
'Kopie anfertigen: 6.00-16.59
strDatNam = Application.GetSaveAsFilename("600_1659", "Excel-Files (*.xls),*.xls,Alle _
Dateien (*.*),*.*")
If strDatNam = "Falsch" Then
MsgBox "Das Programm wird beendet!"
GoTo Ende
End If
.SaveAs Filename:=strDatNam
End With
With Workbooks(Split(strDatNam, "\")(UBound(Split(strDatNam, "\"))))
For Each Ws In .Worksheets
'Zeilen löschen, die in M Zeiten außerhalb von 06:00:00 bis 16:59:00 haben
With Ws
If .Name "Titelblatt" Then 'Titelblatt übergehen
For lngzeile = .Cells(.Rows.Count, "M").End(xlUp).Row To 3 Step -1
If .Cells(lngzeile, "M").Value _
CDate("16:59:00") Then
.Rows(lngzeile).Delete
End If
Next
End If
End With
Next 'nächstes Tabellenblatt
.Save
'Kopie anfertigen: 17.00-18.59
strDatNam = Application.GetSaveAsFilename("1700_1859", "Excel-Files (*.xls),*.xls,Alle _
Dateien (*.*),*.*")
If strDatNam = "Falsch" Then
MsgBox "Das Programm wird beendet!"
GoTo Ende
End If
.SaveAs Filename:=strDatNam
End With
With Workbooks(Split(strDatNam, "\")(UBound(Split(strDatNam, "\"))))
For Each Ws In .Worksheets
'Zeilen löschen, die in M Zeiten außerhalb von 17:00:00 bis 18:59:00 haben
With Ws
If .Name "Titelblatt" Then 'Titelblatt übergehen
For lngzeile = .Cells(.Rows.Count, "M").End(xlUp).Row To 3 Step -1
If .Cells(lngzeile, "M").Value _
CDate("18:59:00") Then
.Rows(lngzeile).Delete
End If
Next
End If
End With
Next 'nächstes Tabellenblatt
.Save
'Kopie anfertigen: 19.00-22.30
strDatNam = Application.GetSaveAsFilename("1900_2230", "Excel-Files (*.xls),*.xls,Alle _
Dateien (*.*),*.*")
If strDatNam = "Falsch" Then
MsgBox "Das Programm wird beendet!"
GoTo Ende
End If
.SaveAs Filename:=strDatNam
End With
With Workbooks(Split(strDatNam, "\")(UBound(Split(strDatNam, "\"))))
For Each Ws In .Worksheets
'Zeilen löschen, die in M Zeiten außerhalb von 19:00:00 bis 22:30:00 haben
With Ws
If .Name "Titelblatt" Then 'Titelblatt übergehen
For lngzeile = .Cells(.Rows.Count, "M").End(xlUp).Row To 3 Step -1
If .Cells(lngzeile, "M").Value _
CDate("22:30:00") Then
.Rows(lngzeile).Delete
End If
Next
End If
End With
Next 'nächstes Tabellenblatt
.Save
'Kopie anfertigen: 22.31-01.00
strDatNam = Application.GetSaveAsFilename("2231_0100", "Excel-Files (*.xls),*.xls,Alle _
Dateien (*.*),*.*")
If strDatNam = "Falsch" Then
MsgBox "Das Programm wird beendet!"
GoTo Ende
End If
.SaveAs Filename:=strDatNam
End With
With Workbooks(Split(strDatNam, "\")(UBound(Split(strDatNam, "\"))))
For Each Ws In .Worksheets
'Zeilen löschen, die in M Zeiten außerhalb von 22:31:00 bis 01:00:00 haben
With Ws
If .Name "Titelblatt" Then 'Titelblatt übergehen
For lngzeile = .Cells(.Rows.Count, "M").End(xlUp).Row To 3 Step -1
If .Cells(lngzeile, "M").Value _
CDate("01:00:00") Then
.Rows(lngzeile).Delete
End If
Next
End If
End With
Next 'nächstes Tabellenblatt
.Save
End With
Ende:
Application.ScreenUpdating = True
Set Ws = Nothing
End Sub