AW: Daten automatisiert aus eine Arbeitsmappe kopi
27.03.2007 14:05:10
fcs
Hallo Sascha,
ich hab das Skript an die veränderten Prüfbedingungen für die ArtikelNr angepasst.
Den Code für die Bedingungen unter 4. hatte ich schon in den Code eingearbeitet.
Ein ist mir noch aufgefallen: Für ArtikelNr "MINDESTLACK" soll eine Sonderberechnung erfolgen.
In der Tabelle hab ich nur ArtikelNr "MINDESTR.LACK" gefunden.
Hier muss du ggf. die Prozedur "Private Sub NachVerkauf()" noch entsprechend anpassen.
Gruß
Franz
Public wks1 As Worksheet, wksVerkauf As Worksheet, wksFertig As Worksheet, wksStrecke As _
Worksheet
Public Z1 As Long, Z1max As Long, ZVerk As Long, ZFertig As Long, ZStrecke 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")
'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, 10)).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, 10)).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, 10)).ClearContents
End If
End With
'Startzeilen in den Tabellen setzen
ZVerk = 2
ZFertig = 2
ZStrecke = 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 "*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 "HVP*" Or ArtikelNr Like "HVB*" 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", "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:J1").Value = wks1.Cells(Z1, 5).Range("A1:J1").Value
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:J1").Value = wks1.Cells(Z1, 5).Range("A1:J1").Value
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:J1").Value = wks1.Cells(Z1, 5).Range("A1:J1").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 "*BLECHANSCHNITTEST*" Then
'Wert in Spalte J (RE in EUR) mit 0,2 multiplizieren
.Cells(ZVerk, 10).Value = .Cells(ZVerk, 10).Value * 0.2
'Wert in Spalte G (HASP%) auf 20 setzen
.Cells(ZVerk, 7).Value = 20#
End If
End With
ZVerk = ZVerk + 1 'Zeilenzähler erhöhen
End Sub