Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

kleiner VBA Code zusammengewürfelt :-(

kleiner VBA Code zusammengewürfelt :-(
05.05.2009 11:23:16
Drusilla
Hallo zusammen
Habe mir einen Code selber zusammengemixt aus verschiedenen Quellen. Funktioniert aber nicht, weil ich die ifs und nexts und das ganze Zeugs wohl nicht richtig gesetzt habe. Könnte da jemand kurz drüber schauen und sagen, was denn noch fehlt, bzw. an falscher Stelle steht? Also quasi ein Korrekturlesen?
Vielen Dank!
Hier der Code:

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
End With
Next  'nächstes Tabellenblatt
'Speichern
ActiveWorkbook.SaveAs Filename:="24h.xls"
Set Ws = Nothing
End With
Ende:
Application.ScreenUpdating = True
Set Ws = Nothing
End Sub


Danke und Gruss,
Drusilla

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: kleiner VBA Code zusammengewürfelt :-(
05.05.2009 11:39:39
Steffen
Hallo ,probier mal den Code:

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")))
End If
'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 'nächstes Tabellenblatt
'Speichern
ActiveWorkbook.SaveAs Filename:="24h.xls"
Set Ws = Nothing
End With
Next
End With
Ende:
Application.ScreenUpdating = True
Set Ws = Nothing
End Sub


Grüße

Anzeige
AW: kleiner VBA Code zusammengewürfelt :-(
05.05.2009 11:49:56
Drusilla
hm, mit deinem code wird das file in endlosschlaufe immer wieder gespeichert...
AW: kleiner VBA Code zusammengewürfelt :-(
05.05.2009 11:41:03
Peter
Hallo Drusilla,
wenn im Bereich J4:Jn immer Daten stehen, sollte es so gehen:


Option Explicit
Sub Output_Standard()
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, 10).End(xlUp).Row
            .Cells(lngzeile + 2, "J").Value = _
                     Application.WorksheetFunction.Average(.Range(.Cells(4, 10), .Cells( _
lngzeile, 10)))
          '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, 10).Value = 0 Then
                  .Rows(lngzeile).Delete
               End If
            Next
         End If
      End With
   Next  'nächstes Tabellenblatt
   'Speichern
   ActiveWorkbook.SaveAs Filename:="24h.xls"
   Set Ws = Nothing
End With


Wobe i ich auch den Sub-Namen am Ende mit einem 'D' versehen habe, denn der soll sicher keine Standarte, sondern Standard bedeuten.
Gruß Peter
Anzeige
AW: kleiner VBA Code zusammengewürfelt :-(
05.05.2009 11:43:40
fcs
Hallo Drusilla,
nach meiner Einschätzung fehlt in diesem Abschnitt des Codes das markierte "End If".
Leider ist die Fehlermeldung des Debuggers irreführend "End With ohne With".
Gruß
Franz

'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
         End If                                        '######   eingefügt fcs
End With
Next  'nächstes Tabellenblatt


Anzeige
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


Anzeige
AW: kleiner VBA Code zusammengewürfelt :-(
05.05.2009 14:11:57
fcs
Hallo Drusilla,
mit folgender Anpassung bleibt die Datei 24h.xls ständig unverändert geöffnet.
Für jeden Zeitraum wird jeweils eine Kopie der Datei gespeichert und diese dann geöffnet und bearbeitet.
Gruß
Franz

Sub Output_Standart()
Dim Ws As Worksheet
Dim lngzeile As Long
Dim strDatNam As String
Dim wb24 As Workbook, wbZeit As Workbook
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
.SaveAs Filename:="24h.xls"
End With
Set wb24 = ActiveWorkbook
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
wb24.SaveCopyAs Filename:=strDatNam
Set wbZeit = Workbooks.Open(Filename:=strDatNam)
With wbZeit
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
.Close savechanges:=False
End With
'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
wb24.SaveCopyAs Filename:=strDatNam
Set wbZeit = Workbooks.Open(Filename:=strDatNam)
With wbZeit
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
.Close savechanges:=False
End With
'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
wb24.SaveCopyAs Filename:=strDatNam
Set wbZeit = Workbooks.Open(Filename:=strDatNam)
With wbZeit
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
.Close savechanges:=False
End With
'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
wb24.SaveCopyAs Filename:=strDatNam
Set wbZeit = Workbooks.Open(Filename:=strDatNam)
With wbZeit
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
.Close savechanges:=False
End With
'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
wb24.SaveCopyAs Filename:=strDatNam
Set wbZeit = Workbooks.Open(Filename:=strDatNam)
With wbZeit
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
.Close savechanges:=False
End With
Ende:
Application.ScreenUpdating = True
Set Ws = Nothing: Set wb24 = Nothing: Set wbZeit = Nothing
End Sub


Anzeige
AW: kleiner VBA Code zusammengewürfelt :-(
05.05.2009 15:25:29
Drusilla
ah super, genau das habe ich gesucht! ist ein hammer forum hier! danke allen vielmals! vielleicht melde ich mich wieder mal mit einem neuen problem. ;-)
gibts irgendwie ein gutes buch, wo man das lernen könnte? find das super spannend und würd gern mehr damit arbeiten

311 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige