AW: Next ohne For
19.02.2008 15:26:00
sascha76er
Hallo Martin,
danke für die schnelle Antwort, hier der Code:
Public wks1 As Worksheet, wksVerkauf As Worksheet, wksFertig As Worksheet, wksStrecke As _
Worksheet, wksFensterbank As Worksheet
Public Z1 As Long, Z1max As Long, ZVerk As Long, ZFertig As Long, ZStrecke As Long, ZFensterbank As Long
Public ArtikelNr As String
Sub Tabelle1_auswerten()
'Übertragung von Daten aus Tabelle1 in die Tabellen Verkauf, Fertigung und Strecke
Set wks1 = Worksheets("Tabelle1")
Set wksVerkauf = Worksheets("Verkauf")
Set wksFertig = Worksheets("Fertigung")
Set wksStrecke = Worksheets("Strecke")
Set wksFensterbank = Worksheets("Fensterbank")
'vorhandene Altdaten in den Tabellen löschen
With wksVerkauf
If .Cells(.Rows.Count, 1).End(xlUp).Row > 1 Then
.Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 14)).ClearContents
End If
End With
With wksFertig
If .Cells(.Rows.Count, 1).End(xlUp).Row > 1 Then
.Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 14)).ClearContents
End If
End With
With wksStrecke
If .Cells(.Rows.Count, 1).End(xlUp).Row > 1 Then
.Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 14)).ClearContents
End If
With wksFensterbank
If .Cells(.Rows.Count, 1).End(xlUp).Row > 1 Then
.Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 14)).ClearContents
End If
End With
'Startzeilen in den Tabellen setzen
ZVerk = 2
ZFertig = 2
ZStrecke = 2
ZFensterbank = 2
With wks1
Z1 = 2 '1.Zeile mit Daten in Tabelle1
'letzte Zeile mit Daten 0 in Tabelle1, Spalte 2
Z1max = .Cells(.Rows.Count, 1).End(xlUp).Row
Do Until .Cells(Z1max, 2).Value 0
Z1max = Z1max - 1
Loop
For Z1 = Z1 To Z1max
'Prüfen der ArtikelNr in Spalte G und ggf. Daten übertragen in eine der Tabellen
ArtikelNr = UCase(.Cells(Z1, 7).Value)
' In der If und den ElseIf-Zeilen werden alle ArtikelNr abgefragt, die nicht_
' in Tabelle Verkauf übertragen werden sollen
If ArtikelNr Like "*ALSOFT*" Then
Call NachFensterbank
If ArtikelNr Like "*STRECKE*" Then
Call NachStrecke
ElseIf ArtikelNr Like "*FERT*" Or ArtikelNr Like "*ROHRBIEGER*" Then
Call NachFertigung
ElseIf ArtikelNr Like "*FRACHT*" Or ArtikelNr Like "*NAUTHFRACHT*" _
Or ArtikelNr Like "KLM*" Or ArtikelNr Like "ABNH*" _
Or ArtikelNr Like "*TRANSPORT*" Or ArtikelNr Like "FKLM1*" _
Or ArtikelNr Like "FHVB*" Or ArtikelNr Like "FHVP*" _
Or ArtikelNr Like "FHVFERT*" Or ArtikelNr Like "PGF*" _
Or ArtikelNr Like "HVFERT" Or ArtikelNr Like "EINWEG-WELLPAPP-*" _
Or ArtikelNr Like "HVB*" Or ArtikelNr Like "HVP*" _
Or ArtikelNr Like "BIEHLFR*" Or ArtikelNr Like "HSF*" Then
'do nothing, bei diesen Werten sollen keine Übertragungen erfolgen
Else
'Übertragung nach Tabelle Verkauf außer Sonderwerte
Select Case UCase(.Cells(Z1, 6).Value) 'Kundenname
Case "AUßENLAGER ECKER", "UMBUCHUNG", "KONSI - LAGER-FERTIGUNG", "LAGER KLARENTHAL", "BESTANDSKORREKTUR"
'do nothing, es sollen keine Daten übertragen werden
Case Else
Call NachVerkauf
End Select
End If
Next
End With
End Sub
Private Sub NachStrecke()
'Daten nach Tabelle Strecke übertragen
With wksStrecke
.Cells(ZStrecke, 1).Range("A1:N1").Value = wks1.Cells(Z1, 1).Range("A1:N1").Value
'Artikelnummern bei denen zusätzlich Werte geändert werden sollen
If ArtikelNr Like "*ELOXAL*" Or ArtikelNr Like "*PULVER*" _
Or ArtikelNr Like "*VERPACKUNG*" Or ArtikelNr Like "*MINDESTLACK*" _
Or ArtikelNr Like "*DELWOSCHLIFF*" Or ArtikelNr Like "*PROFILANSCHNITTEKG*" _
Or ArtikelNr Like "*PROFILANSCHNITTEM*" Or ArtikelNr Like "*BLECHANSCHNITTEKG*" _
Or ArtikelNr Like "*ALPRELOXALM*" Or ArtikelNr Like "*ALPRELOXE6EV1DIV*" _
Or ArtikelNr Like "*ALPRELOXE61003DIV*" Or ArtikelNr Like "*PU*KLEIN*" _
Or ArtikelNr Like "*PU*ALBL*" Or ArtikelNr Like "*PUAUSBESSERUNG*" _
Or ArtikelNr Like "*PU*ALFERT*" Or ArtikelNr Like "*PU*ALPR*" _
Or ArtikelNr Like "*PU*STPR*" Or ArtikelNr Like "*FARBWECHSEL*" _
Or ArtikelNr Like "*PUALDIVERSE*" Or ArtikelNr Like "*MINDESTR.LACK*" _
Or ArtikelNr Like "*PU3012ALKLEIN*" Or ArtikelNr Like "*PUEISENGLIMMER*" _
Or ArtikelNr Like "*PUALSONDERFARBEN*" Or ArtikelNr Like "*PU*RAHMEN*" _
Or ArtikelNr Like "*PU1*STBL*" Or ArtikelNr Like "*PU*STFERT*" _
Or ArtikelNr Like "*PUDIVERSE*" Or ArtikelNr Like "*PUSTDIVERSE*" _
Or ArtikelNr Like "*CONTAINER*" Or ArtikelNr Like "*PUSTDIVERSE*" _
Or ArtikelNr Like "*ALSOFTLACKM" Or ArtikelNr Like "*ALSOFTLACKST" _
Or ArtikelNr Like "*BLECHANSCHNITTEST*" Then
'Wert in Spalte N (RE in EUR) mit 0,2 multiplizieren
.Cells(ZVerk, 14).Value = .Cells(ZVerk, 14).Value * 0.2
'Wert in Spalte K (HASP%) auf 20 setzen
.Cells(ZVerk, 11).Value = 20#
End If
End With
ZStrecke = ZStrecke + 1 'Zeilenzähler erhöhen
End Sub
Private Sub NachFertigung()
'Daten nach Tabelle Fertigung übertragen
With wksFertig
.Cells(ZFertig, 1).Range("A1:N1").Value = wks1.Cells(Z1, 1).Range("A1:N1").Value
'Artikelnummern bei denen zusätzlich Werte geändert werden sollen
If ArtikelNr Like "*ELOXAL*" Or ArtikelNr Like "*PULVER*" _
Or ArtikelNr Like "*VERPACKUNG*" Or ArtikelNr Like "*MINDESTLACK*" _
Or ArtikelNr Like "*DELWOSCHLIFF*" Or ArtikelNr Like "*PROFILANSCHNITTEKG*" _
Or ArtikelNr Like "*PROFILANSCHNITTEM*" Or ArtikelNr Like "*BLECHANSCHNITTEKG*" _
Or ArtikelNr Like "*ALPRELOXALM*" Or ArtikelNr Like "*ALPRELOXE6EV1DIV*" _
Or ArtikelNr Like "*ALPRELOXE61003DIV*" Or ArtikelNr Like "*PU*KLEIN*" _
Or ArtikelNr Like "*PU*ALBL*" Or ArtikelNr Like "*PUAUSBESSERUNG*" _
Or ArtikelNr Like "*PU*ALFERT*" Or ArtikelNr Like "*PU*ALPR*" _
Or ArtikelNr Like "*PU*STPR*" Or ArtikelNr Like "*FARBWECHSEL*" _
Or ArtikelNr Like "*PUALDIVERSE*" Or ArtikelNr Like "*MINDESTR.LACK*" _
Or ArtikelNr Like "*PU3012ALKLEIN*" Or ArtikelNr Like "*PUEISENGLIMMER*" _
Or ArtikelNr Like "*PUALSONDERFARBEN*" Or ArtikelNr Like "*PU*RAHMEN*" _
Or ArtikelNr Like "*PU1*STBL*" Or ArtikelNr Like "*PU*STFERT*" _
Or ArtikelNr Like "*PUDIVERSE*" Or ArtikelNr Like "*PUSTDIVERSE*" _
Or ArtikelNr Like "*CONTAINER*" Or ArtikelNr Like "*PUSTDIVERSE*" _
Or ArtikelNr Like "*ALSOFTLACKM" Or ArtikelNr Like "*ALSOFTLACKST" _
Or ArtikelNr Like "*BLECHANSCHNITTEST*" Then
'Wert in Spalte N (RE in EUR) mit 0,2 multiplizieren
.Cells(ZVerk, 14).Value = .Cells(ZVerk, 14).Value * 0.2
'Wert in Spalte K (HASP%) auf 20 setzen
.Cells(ZVerk, 11).Value = 20#
End If
End With
ZFertig = ZFertig + 1 'Zeilenzähler erhöhen
End Sub
Private Sub NachVerkauf()
'Daten nach Tabelle Verkauf übertragen
With wksVerkauf
'Zellinhalte aus Tabelle1 nach Tabelle Verkauf übertragen
.Cells(ZVerk, 1).Range("A1:N1").Value = wks1.Cells(Z1, 1).Range("A1:N1").Value
'Artikelnummern bei denen zusätzlich Werte geändert werden sollen
If ArtikelNr Like "*ELOXAL*" Or ArtikelNr Like "*PULVER*" _
Or ArtikelNr Like "*VERPACKUNG*" Or ArtikelNr Like "*MINDESTLACK*" _
Or ArtikelNr Like "*DELWOSCHLIFF*" Or ArtikelNr Like "*PROFILANSCHNITTEKG*" _
Or ArtikelNr Like "*PROFILANSCHNITTEM*" Or ArtikelNr Like "*BLECHANSCHNITTEKG*" _
Or ArtikelNr Like "*ALPRELOXALM*" Or ArtikelNr Like "*ALPRELOXE6EV1DIV*" _
Or ArtikelNr Like "*ALPRELOXE61003DIV*" Or ArtikelNr Like "*PU*KLEIN*" _
Or ArtikelNr Like "*PU*ALBL*" Or ArtikelNr Like "*PUAUSBESSERUNG*" _
Or ArtikelNr Like "*PU*ALFERT*" Or ArtikelNr Like "*PU*ALPR*" _
Or ArtikelNr Like "*PU*STPR*" Or ArtikelNr Like "*FARBWECHSEL*" _
Or ArtikelNr Like "*PUALDIVERSE*" Or ArtikelNr Like "*MINDESTR.LACK*" _
Or ArtikelNr Like "*PU3012ALKLEIN*" Or ArtikelNr Like "*PUEISENGLIMMER*" _
Or ArtikelNr Like "*PUALSONDERFARBEN*" Or ArtikelNr Like "*PU*RAHMEN*" _
Or ArtikelNr Like "*PU1*STBL*" Or ArtikelNr Like "*PU*STFERT*" _
Or ArtikelNr Like "*PUDIVERSE*" Or ArtikelNr Like "*PUSTDIVERSE*" _
Or ArtikelNr Like "*CONTAINER*" Or ArtikelNr Like "*PUSTDIVERSE*" _
Or ArtikelNr Like "*ALSOFTLACKM" Or ArtikelNr Like "*ALSOFTLACKST" _
Or ArtikelNr Like "*BLECHANSCHNITTEST*" Then
'Wert in Spalte N (RE in EUR) mit 0,2 multiplizieren
.Cells(ZVerk, 14).Value = .Cells(ZVerk, 13).Value * 0.2
'Wert in Spalte K (HASP%) auf 20 setzen
.Cells(ZVerk, 11).Value = 20#
End If
End With
ZVerk = ZVerk + 1 'Zeilenzähler erhöhen
End Sub
Private Sub NachFensterbank()
'Daten nach Tabelle Fensterbank übertragen
With wksFensterbank
'Zellinhalte aus Tabelle1 nach Tabelle Fensterbank übertragen
.Cells(ZFensterbank, 1).Range("A1:N1").Value = wks1.Cells(Z1, 1).Range("A1:N1").Value
'Artikelnummern bei denen zusätzlich Werte geändert werden sollen
If ArtikelNr Like "*ALSOFTLACKM*" Or ArtikelNr Like "ALSOFTLACKST*" Then
'Wert in Spalte N (RE in EUR) mit 0,2 multiplizieren
.Cells(ZVerk, 14).Value = .Cells(ZVerk, 14).Value * 0.2
'Wert in Spalte K (HASP%) auf 20 setzen
.Cells(ZVerk, 11).Value = 20#
End If
End With
ZFensterbank = ZFensterbank + 1 'Zeilenzähler erhöhen
End Sub
Gruß
Sascha