Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
756to760
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
756to760
756to760
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Makro Personl Fehlermeldungen

Makro Personl Fehlermeldungen
30.04.2006 22:19:53
Uwe
Hallo Zusammen,
ich habe in einer Excel-Datei in einem Modul unten aufgeführtes Makro.
Jetzt wollte ich es in der Personl.xls für alle neuen Arbeitsmappen
zur Verfügung haben.
Das Anlegen der Personl.xls, Modul anlegen, usw. kein Problem.
Aber, wenn ich das Makro starten will, kommen ständig Fehlermeldungen.
(Index ausserhalb des Bereiches, Fehler 9; ...)
Es wäre super, wenn mir jemand von euch zeigen könnte, wie bzw.
welche Befehle abgeändert werden müssten, damit es funktioniert.
Wäre echt klasse.
Schon mal vielen Dank für eure Zeit und Mühe
Viele Grüße
Uwe

Sub Zusammenfassen_FibuKto()
'Überträgt Daten aus den Abteilungs-Tabellen in die Zusammenfassung B
Dim wksZus As Worksheet
Dim wksZusB As Worksheet
Dim wksAbt As Worksheet
Dim vorhanden As Boolean
Dim Bereich As Range
Dim TextAbt As String
Dim TextZus As String
Dim i As Integer
Dim k As Integer
Dim ZeileAbt As Integer
Dim ZeileZus As Integer
Dim Zelle As Range
Dim SpPN As Integer
Dim SpLA As Integer
Dim SpFK As Integer
Dim SpKS As Integer
Dim Boxtext As String
wkszusa = "Zusammenfassung B"
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
'  .Cursor = xlWait
End With
Start = Timer
Debug.Print "*****************************************************"
Debug.Print "*** gestartet um: " & Format(Now - j, "hh:mm:ss")
For i = 1 To Worksheets.Count
If Sheets(i).Name = wkszusa Then
'        ActiveSheet.Name = wksZusa
Sheets(wkszusa).Select
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayZeros = False
GoTo ende
End If
Next i
Worksheets.Add
ActiveSheet.Name = wkszusa
Sheets(wkszusa).Select
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayZeros = False
ende:
Set wksZus = ThisWorkbook.Sheets("Zusammenfassung B")
Set wksZusB = ThisWorkbook.Sheets("Zusammenfassung A")
Set Bereich = wksZus.Range("A1:F" & wksZus.UsedRange.Rows.Count)
letztespalte = wksZus.Cells(1, 256).End(xlToLeft).Column
Bereich.ClearContents 'Alte Daten in Zusammenfassung B löschen
' wksZus.Range("A1").FormulaR1C1 = "PersNr"
wksZus.Range("A1").FormulaR1C1 = "Konto"
' wksZus.Range("C1").FormulaR1C1 = "KoStNr"
wksZus.Range("C1").FormulaR1C1 = "S+P"
wksZus.Range("D1").FormulaR1C1 = "TPO"
wksZus.Range("F1").FormulaR1C1 = "Differenzen"
With wksZus.Range("A1")
.HorizontalAlignment = xlCenter
.Interior.ColorIndex = 15
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
End With
With wksZus.Range("C1:D1")
.HorizontalAlignment = xlCenter
.Interior.ColorIndex = 15
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
End With
With wksZus.Range("F1")
.HorizontalAlignment = xlCenter
.Interior.ColorIndex = 15
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
End With
ZeileZus = 2 'Startzeile in Zusammenfassung B für Dateneinträge
For Each wksAbt In ThisWorkbook.Sheets
'Zu überspringende Tabellen
If wksAbt.Name = wksZus.Name And wksAbt.Name = wksZusB.Name Then GoTo nexttabelle
' Spaltennummern in Titelzeile der Abteilungsdaten ermitteln
With wksAbt
Set Bereich = .Range(.Cells(1, 1), .Cells(1, .UsedRange.Columns.Count))
End With
'    SpPN = 0
'    SpLA = 0
SpFK = 0
'    SpKS = 0
For Each Zelle In Bereich
Select Case Zelle.Value
'      Case "PersNr"
'        SpPN = Zelle.Column
'      Case "LANr"
'        SpLA = Zelle.Column
Case "Konto"
SpFK = Zelle.Column
'      Case "KoStNr"
'        SpKS = Zelle.Column
End Select
Next Zelle
' Überprüfung ob alle 4 Spaltentitel gefunden wurden
'                            Boxtext = "In Tabelle " & wksAbt.Name & vbLf & " wurde der Spaltentitel "
'                            If SpPN = 0 Then
'                              MsgBox Boxtext & "'PersNr' nicht gefunden"
'                              SpPN = 20 'Dummyspalte ohne Daten
'                            End If
'    If SpLA = 0 Then
'      MsgBox Boxtext & "'Lohnart' nicht gefunden"
'      SpLA = 20 'Dummyspalte ohne Daten
'    End If
If SpFK = 0 Then
MsgBox Boxtext & "'Fibu-Konto' nicht gefunden"
SpFK = 20 'Dummyspalte ohne Daten
End If
'                            If SpKS = 0 Then
'                              MsgBox Boxtext & "'Kostenstelle' nicht gefunden"
'                              SpKS = 20 'Dummyspalte ohne Daten
'                            End If
' Abarbeiten der Zeilen in den Abteilungs-Tabellen
For ZeileAbt = 2 To wksAbt.UsedRange.Rows.Count
vorhanden = False
' PersNr  Lohnart Fibu-Konto  Kostenstelle in Abteilungs-Tabelle
With wksAbt
' Leerzellen für Sortierung Wert 0 zuweisen
'        If IsEmpty(.Cells(ZeileAbt, SpLA)) Then .Cells(ZeileAbt, SpLA) = 0
'        If IsEmpty(.Cells(ZeileAbt, SpFK)) Then .Cells(ZeileAbt, SpFK) = 0
'        If .Cells(ZeileAbt, SpFK) = "" Then .Cells(ZeileAbt, SpFK) = 0
'        If IsEmpty(.Cells(ZeileAbt, SpKS)) Then .Cells(ZeileAbt, SpKS) = 0
'        If .Cells(ZeileAbt, SpKS) = "0" Then .Cells(ZeileAbt, SpKS) = "1"
'        TextAbt = .Cells(ZeileAbt, SpPN) & .Cells(ZeileAbt, SpLA) & .Cells(ZeileAbt, SpFK) & .Cells(ZeileAbt, SpKS)
TextAbt = .Cells(ZeileAbt, SpFK)
End With
' Vergleich mit den vorhandenen Einträgen in der Zusammenfassung B
For i = 1 To ZeileZus
' PersNr  Lohnart Fibu-Konto  Kostenstelle in Zusammenfassungs-Tabelle
With wksZus
'          TextZus = .Cells(i, 1) & .Cells(i, 2) & .Cells(i, 3) & .Cells(i, 4)
TextZus = .Cells(i, 1)
End With
If TextAbt = TextZus Or TextAbt = "0" Then 'Überprüfung auf Doppeleintrag
vorhanden = True
Exit For
End If
Next i
If vorhanden = False Then
' Neuer Eintrag in Zusammenfassung B
With wksZus
'          .Cells(ZeileZus, 1) = wksAbt.Cells(ZeileAbt, SpPN)
'          .Cells(ZeileZus, 2) = wksAbt.Cells(ZeileAbt, SpLA)
.Cells(ZeileZus, 1) = wksAbt.Cells(ZeileAbt, SpFK)
'          .Cells(ZeileZus, 3) = wksAbt.Cells(ZeileAbt, SpKS)
End With
ZeileZus = ZeileZus + 1
End If
Next ZeileAbt
nexttabelle:
Next wksAbt
'Zusammenfassung B sortieren
Set Bereich = wksZus.Range("A2:A" & wksZus.UsedRange.Rows.Count)
'Zusammenfassung B sortieren nach Spalte Kostenstelle
'  Bereich.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
'        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'      Range("A2:F21").Select
Bereich.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'  'Zusammenfassung B sortieren nach Spalten PersNr,  Lohnart und Fibu-Konto
'  Bereich.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _
'        , Order2:=xlAscending, Key3:=Range("C2"), Order3:=xlAscending, Header:= _
'        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'Hilfsweise eingetragene Nullwerte wieder aus der Tabelle entfernen
Set Bereich = wksZus.Range("A2:A" & wksZus.UsedRange.Rows.Count)
For Each Zelle In Bereich
If Zelle.Value = 0 Then Zelle.ClearContents
Next Zelle
'Tabelle: Zusammenfassung B
'Autofilter: Konto 888888 entfernen
Set Bereich = wksZus.Range("A2:C" & wksZus.UsedRange.Rows.Count)
Range("A1:F1").Select
Selection.Autofilter
Selection.Autofilter Field:=1, Criteria1:="888888"
Bereich.Select
Selection.EntireRow.Delete
Selection.Autofilter Field:=1
Selection.Autofilter
Range("A1").Select
'Tabelle: Zusammenfassung B
'Autofilter: Konto Leere(Zellen) entfernen
'    Set Bereich = wksZus.Range("A2:A" & wksZus.UsedRange.Rows.Count)
'    Range("A1").Select
'    Selection.Autofilter
'    Selection.Autofilter Field:=1, Criteria1:="="
'    Bereich.Select
'    Selection.EntireRow.Delete
'    Selection.Autofilter Field:=1
'    Selection.Autofilter
'    Range("A1").Select
'Tabelle: Zusammenfassung B
'Autofilter: Konto 1 entfernen
Set Bereich = wksZus.Range("A2:C" & wksZus.UsedRange.Rows.Count)
Range("A1:F1").Select
Selection.Autofilter
Selection.Autofilter Field:=1, Criteria1:="1"
Bereich.Select
Selection.EntireRow.Delete
Selection.Autofilter Field:=1
Selection.Autofilter
Range("A1").Select
ErrExit:
If Err.Number > 0 Then
MsgBox Err.Number & vbLf & Err.Description, , "Fehler"
Err.Clear
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
.Cursor = xlDefault
End With
Debug.Print "*** beendet um: " & Format(Now - j, "hh:mm:ss")
Debug.Print "*** " & Format(Timer - Start, "#0.00") & " Sekunden gerödelt!"
Debug.Print "*****************************************************"
End Sub

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Makro Personl Fehlermeldungen
30.04.2006 22:41:56
Nepumuk
Hallo Uwe,
du musst immer mit ActiveWorkbook arbeiten. Also, an Stelle von:
For i = 1 To Worksheets.Count
schreibst du:
For i = 1 To ActiveWorkbook.Worksheets.Count
oder, an Stelle von:
For Each wksAbt In ThisWorkbook.Sheets
schreibst du:
For Each wksAbt In ActiveWorkbook.Sheets
Gruß
Nepumuk

AW: Makro Personl Fehlermeldungen
30.04.2006 23:01:05
Uwe
Hallo Nepumuk,
vielen Dank für die superschnelle Antwort.
Werde es gleich mal ausprobieren.
Wird wohl etwas dauern.
Wenn ich noch Probleme habe melde ich mich nochmal.
Aber super und vielen Dank für Deine Hilfe.
Gruß
Uwe
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige