1.9k Aufrufe
Gefragt in Tabellenkalkulation von benjaminm Mitglied (631 Punkte)
Hallo @all,
Hab da ein Problem, ein netter Supportneter hat mir 2009 bei einem Makro geholfen, jedoch 2011 will das nicht mehr.

Ich finde den Fehler aber nicht!

Hier mal der Code:
Sub Pal_ab_Jun_09()
'
' Makro1 Makro
' Makro am 02.06.2009 von bauer aufgezeichnet
'

'
Dim Monat
Monat = Array("", "Jan", "Feb", "Mrz", "Apr", "Mai", "Jun", "Jul", "Aug", "Sep", "Okt", "Nov", "Dez")
Name = ActiveSheet.Name

ActiveSheet.Unprotect Password:=""

Mon = Left(Name, 3)
Jah = Val(Right(Name, 2)) + 2000
For i = 1 To 12
If Mon = Monat(i) Then Mon_z = i
Next i
letzte_Zeile_a = Range("A65536").End(xlUp).Row
letzte_Zeile = Range("M65536").End(xlUp).Row 'geändert
If letzte_Zeile_a > letzte_Zeile Then letzte_Zeile = letzte_Zeile_a
Range("A7:V" & letzte_Zeile).Select 'geändert
Selection.Delete Shift:=xlUp
Datum_begin = DateSerial(Jah, Mon_z, 1)
Datum_ende = DateSerial(Jah, Mon_z + 1, 0)

Sheets("Pal.Ausgang").Select
letzte_Zeile = Range("A65536").End(xlUp).Row
Range("A7:L" & letzte_Zeile).Select 'geändert
Application.CutCopyMode = False
Selection.Copy
Sheets(Name).Select
Range("A7").Select
ActiveSheet.Paste

letzte_Zeile_a = Range("A65536").End(xlUp).Row 'verschoben

Range("K7:K" & letzte_Zeile_a).Select 'Neu Anfang
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft 'Neu Ende

Sheets("Pal.Eingang").Select
letzte_Zeile = Range("A65536").End(xlUp).Row
Range("A7:L" & letzte_Zeile).Select
Application.CutCopyMode = False
Selection.Copy
Sheets(Name).Select
Range("M7").Select 'geändert
ActiveSheet.Paste

letzte_Zeile = Range("M65536").End(xlUp).Row 'geändert
If letzte_Zeile_a > letzte_Zeile Then letzte_Zeile = letzte_Zeile_a
For i = letzte_Zeile To 7 Step -1
If Range("A" & i).Value > Datum_ende Or Range("A" & i).Value < Datum_begin Then
Range("A" & i & ":K" & i).Select 'geändert
Selection.Delete Shift:=xlUp
End If
If Range("M" & i).Value > Datum_ende Or Range("M" & i).Value < Datum_begin Then 'geändert
Range("M" & i & ":x" & i).Select 'geändert
Selection.Delete Shift:=xlUp
End If
Next i


'
Range("A4:E4").Select
ActiveCell.FormulaR1C1 = "=SUMME-R[1]C[24]"
Range("A4:E4").Select
ActiveCell.FormulaR1C1 = "=SUM(R[3]C[6]:R[399]C[6])"
Range("S4:V4").Select
ActiveCell.FormulaR1C1 = "=SUM(R[3]C:R[399]C)"

ActiveSheet.Protect Password:=""

End Sub


Habe lediglich die Position zum einfügen 4 zeilen nach unten versetzt, von Zeile 3 auf Zeile 7.
nur leider trägt er mir gakeine Daten mehl in die Monatsblätter ein.
Hier noch mal die Datei dazu. VBA Modul 4

Bitte um hilfe

MfG Benjamin

4 Antworten

0 Punkte
Beantwortet von saarbauer Profi (15.6k Punkte)
hallo,

Mon = Left(Name, 3)
Jah = Val(Right(Name, 2)) + 2000


da hier das Datum im Blattnamen ausgewertet wird, kann es nicht funktionieren. In den ursprünglichen Blättern (die mir aus anderen Anfragen bekannt sind) stand als Blattname z.B. "Jan10" , somit kann es hier mit "Jan" nicht funktionieren.

Hier ist eine andere Lösung erforderlich, ersetze die Zeile "Jah=...." durch

Jah = Range("Stammdaten!D6").Value

damit müsste es klappen

Gruß

Helmut
0 Punkte
Beantwortet von benjaminm Mitglied (631 Punkte)
Hallo Helmut,

Super, fetten Dank!
Das Funktioniert!

Hab nun noch eine Kleinigkeit, er löscht mir in den Monatsblättern immer die Zeile 6 aus welchen gründen auch immer!?

Habe im VBA die erst einzutragende Zeile 7 vorgegeben jedoch löscht er sofort beim Start des Makros die Zeile 6. Weiß aber nicht warum.

Siehst du da was?

MfG
Benjamin
0 Punkte
Beantwortet von benjaminm Mitglied (631 Punkte)
Hallo Helmut,

habs gefunden und es Funtz!

Noch mal Herzlichen Danke für deine Schnelle Hilfe.

MfG
Benjamin
0 Punkte
Beantwortet von beverly Experte (3.5k Punkte)
Hi Benjamin,

in VBA kann man zu 99% auf Select und Activate verzichten - das beschleunigt das Projekt wesentlich:

Sub PalNeu()
Dim Monat
Dim bytMonat As Byte
Monat = Array("Jan", "Feb", "Mrz", "Apr", "Mai", "Jun", "Jul", "Aug", "Sep", "Okt", "Nov", "Dez")
With ActiveSheet
On Error Resume Next
bytMonat = Application.Match(.Name, Monat, 0)
On Error GoTo 0
If bytMonat > 0 Then
.Unprotect
letzte_Zeile_a = .Range("A65536").End(xlUp).Row
letzte_Zeile = .Range("M65536").End(xlUp).Row
If letzte_Zeile_a > letzte_Zeile Then letzte_Zeile = letzte_Zeile_a
If letzte_Zeile_a > 6 Then .Range("A7:V" & letzte_Zeile).Delete Shift:=xlUp
Datum_begin = DateSerial(Worksheets("Stammdaten").Range("D6"), Application.Match(.Name, Monat, 0), 1)
Datum_ende = DateSerial(Worksheets("Stammdaten").Range("D6"), Application.Match(.Name, Monat, 0) + 1, 0)
Sheets("Pal.Ausgang").Range("A3:L" & Sheets("Pal.Ausgang").Range("A65536").End(xlUp).Row).Copy .Range("A7")
.Range("K7:K" & .Range("A65536").End(xlUp).Row).Delete Shift:=xlToLeftEnde
Sheets("Pal.Eingang").Range("A3:L" & Sheets("Pal.Eingang").Range("A65536").End(xlUp).Row).Copy .Range("M7")
letzte_Zeile_a = .Range("A65536").End(xlUp).Row
letzte_Zeile = .Range("M65536").End(xlUp).Row
If letzte_Zeile_a > letzte_Zeile Then letzte_Zeile = letzte_Zeile_a
For i = letzte_Zeile To 7 Step -1
If .Range("A" & i) <> "" And (.Range("A" & i) > Datum_ende Or Range("A" & i) < Datum_begin) Then
.Range("A" & i & ":K" & i).Delete Shift:=xlUp
End If
If .Range("M" & i) <> "" And (.Range("M" & i) > Datum_ende Or .Range("M" & i) < Datum_begin) Then 'geändert
.Range("M" & i & ":X" & i).Delete Shift:=xlUp
End If
Next i
.Protect
Else
MsgBox "Mitte ein Monats-Tabellenblatt auswählen"
End If
End With
End Sub

Du musst auch noch einmal deine Spalten überprüfen, ob die Daten richtig eingetragen werden (betrifft die Spalten für den Paletteneingang).

Bis später,
Karin
...