AW: Benutzerdefiniertes Diagramm
02.12.2008 16:07:17
adrian
Hi Karin,
habe es ja wie von dir beschrieben gemacht. Bin zwar VBA-Anfänger, aber das war nicht so schwer =)
Hier mal der ganze Code von dem Sheet "Overview", hoffe es hilft!
Die ganze Excel file darf ich nicht hochladen, weil das unter interne, wichtige Firmendaten fällt =(
Wo es hakt, bzw. was ich machen will habe ich dir ja genau beschrieben!
In dem Code sind eigentlich nur folgende Abschnitte für das Problem interessant:
####Aufnahme der Philips ODM für "Pie-Data"####
und
####Werte für "Pie-Data" zuordnen####
ist ein ziemliches Durcheinander, was ich da zusammen geschustert habe!
sry dafür und Danke schon mal für deine Geduld!
lg adrian
Private rangeListeA As Range, rangeListeB As Range, rangeListe1 As Range, _
rangeListe2 As Range, rangeListe2A As Range, rangeZielA As Range, rangeZielB As Range, _
rangeZiel1 As Range, rangeZiel2 As Range, rangeZiel2A As Range
Private Sub Worksheet_Activate()
Dim Cell As Range, Datenblatt As Worksheet
Dim i As Integer
Set Datenblatt = Worksheets("Overview")
With Me.ListBox1
.Clear
For Each Cell In Worksheets("Overview").Range("PhilipsODM")
.AddItem Cell.Value
Next
End With
'####Aufnahme der Philips ODM!####
Dim area1 As String
area1 = "PhilipsODM"
Set rangeListe1 = Nothing
Application.Range(area1).ClearContents
Set rangeZiel1 = Application.Range(area1).Range("A1")
Call Bereich1_Auslesen(rangePhilips:=Worksheets("Philips (A)").Range("SupplierAs"))
Call Bereich1_Auslesen(rangePhilips:=Worksheets("Philips (EU)").Range("SupplierEU"))
Call Bereich1_Auslesen(rangePhilips:=Worksheets("philips (US)").Range("SupplierUS"))
With rangeListe1
Application.Names(area1).RefersTo = "='" & .Parent.Name & "'!" & .Address
End With
'####Aufnahme der Philips ODM für "Pie-Data"####
Dim area2 As String
area2 = "PhilipsODM2"
Set rangeListe2 = Nothing
Application.Range(area2).ClearContents
Set rangeZiel2 = Application.Range(area2).Range("A1")
Call Philips_Auspressen(rangeSector2:=Worksheets("Overview").Range("PhilipsODM"))
With rangeListe2
Application.Names(area2).RefersTo = "='" & .Parent.Name & "'!" & .Address
End With
'####Aufnahme aller ODMs!####
Dim areaA As String
areaA = "ODMListA" 'Bereichsname der Werte aufnehmen soll
Set rangeListeA = Nothing
'######## Befehle, wenn vorhandene Werte gelöscht werden sollen #########
Application.Range(areaA).ClearContents
'1. Zelle der Liste setzen
Set rangeZielA = Application.Range(areaA).Range("A1")
'######### Befehle, wenn vorhandene Werte nicht gelöscht werden sollen ########
'Set rngListe = Application.Range(strName)
'letzte Zelle innerhalb der Liste setzen
'Set rngZiel = rngListe.Range("A1").Offset(rngListe.Rows.Count - 1, 0)
Call Bereich_Auslesen(rangeBereich:=Worksheets("Philips (A)").Range("SupplierAs"))
Call Bereich_Auslesen(rangeBereich:=Worksheets("Philips (EU)").Range("SupplierEU"))
Call Bereich_Auslesen(rangeBereich:=Worksheets("Philips (US)").Range("SupplierUS"))
With rangeListeA
'Listenbereich dem Namen neu zuweisen
Application.Names(areaA).RefersTo = "='" & .Parent.Name & "'!" & .Address
End With
Dim areaB As String, ODMBZeile As Long, ODMBSpalte As Long, Found As String, Kontrollzelle As _
Range
areaB = "ODMListB"
Set rangeListeB = Nothing
Application.Range(areaB).ClearContents
Set rangeZielB = Application.Range(areaB).Range("A1")
Call AllODM_Auslesen(rangeSector:=Worksheets("Overview").Range("ODMListA"))
With rangeListeB
Application.Names(areaB).RefersTo = "='" & .Parent.Name & "'!" & .Address
End With
ODMBZeile = 33
With Datenblatt
ODMBSpalte = .Cells(ODMBZeile, .Columns.Count).End(xlToLeft).Column
Set Kontrollzelle = .Cells(ODMBZeile, ODMBSpalte)
End With
While Found "Yes"
For Each Cell In Range("ODMListA")
If Cell.Value = Kontrollzelle.Value Then
Found = "Yes"
End If
Next
If Found "Yes" Then
Kontrollzelle.Value = ""
Set Kontrollzelle = Kontrollzelle.Offset(0, -6)
End If
Wend
For Each Cell In Range("ODMListB")
If Cell.Value "" Then
'AddTextBox
End If
Next
'###Supplier Daten Auflisten!###
Dim Spalte As Long
Dim Zeile As Long, SpalteL As Long, SpalteR As Range, varSupplier, Bereich As String
Zeile = 70 'Zeile mit den Suppliernamen im Hauptdatenblatt
Const Spalte1 As Long = 18 'Spalte,die die erste Spalte in Zeile 70 mit Suppliername ist!
With Datenblatt
SpalteL = .Cells(Zeile, .Columns.Count).End(xlToLeft).Column
For Spalte = Spalte1 To SpalteL
.Range(.Cells(Zeile + 1, Spalte), .Cells(Zeile + 5, Spalte)).ClearContents
'Suppliername für Suche merken
varSupplier = .Cells(Zeile, Spalte).Value
'Supplier in den 3 Blättern im benamten bereich suchen
'Wert aus Spalte links von gefundener Zelle in Zeile 71 eintragen
Call Suchen(rngBereich:=Worksheets("Philips (A)").Range("SupplierAs"), _
varSuchen:=varSupplier, wks:=Datenblatt, ZielZeile:=Zeile + 1, ZielSpalte:=Spalte)
'Wert aus Spalte links von gefundener Zelle in Zeile 72 eintragen
Call Suchen(rngBereich:=Worksheets("Philips (EU)").Range("SupplierEU"), _
varSuchen:=varSupplier, wks:=Datenblatt, ZielZeile:=Zeile + 2, ZielSpalte:=Spalte)
'Wert aus Spalte links von gefundener Zelle in Zeile 73 eintragen
Call Suchen(rngBereich:=Worksheets("Philips (US)").Range("SupplierUS"), _
varSuchen:=varSupplier, wks:=Datenblatt, ZielZeile:=Zeile + 3, ZielSpalte:=Spalte)
.Cells(Zeile + 5, Spalte).Value = .Cells(Zeile + 1, Spalte).Value + _
.Cells(Zeile + 2, Spalte).Value + .Cells(Zeile + 3, Spalte).Value
Next
Set SpalteR = .Range(.Cells(Zeile + 1, SpalteL + 1), .Cells(Zeile + 5, SpalteL + 1))
With SpalteR
While Bereich "Sauber"
i = 0
For Each Cell In SpalteR
If Cell.Value "" Then
Cell.Clear
Else
i = i + 1
End If
Next
If i = 5 Then
Bereich = "Sauber"
Else
Set SpalteR = SpalteR.Offset(0, 1)
End If
Wend
End With
End With
'####Werte für "Pie-Data" zuordnen####
Dim area3 As String
area3 = "PhilipsODMPieData"
Set rangeListe2A = Nothing
Application.Range(area3).ClearContents
Set rangeZiel2A = Application.Range(area3).Range("A1")
Call Philips_Ausquetschen(rangeSector3:=Worksheets("Overview").Range("PhilipsODM"))
With rangeListe2A
Application.Names(area3).RefersTo = "='" & .Parent.Name & "'!" & .Address
End With
End Sub
'####Auslesen aller ODMs!####
Private Sub Bereich_Auslesen(rangeBereich As Range)
Dim rangeGefunden As Range
Dim Zelle As Range
For Each Zelle In rangeBereich
If Zelle "" Then
If rangeListeA Is Nothing Then
rangeZielA = Zelle.Value
Set rangeListeA = rangeZielA
Else
With rangeListeA
Set rangeGefunden = .Find(what:=Zelle.Value, LookIn:=xlValues, Lookat:=xlWhole)
If rangeGefunden Is Nothing Then
Set rangeZielA = rangeZielA.Offset(1, 0)
rangeZielA.Value = Zelle.Value
Set rangeListeA = Union(rangeListeA, rangeZielA)
End If
End With
End If
End If
Next
End Sub
'####nochmals auslesen aller ODMs!####
Private Sub AllODM_Auslesen(rangeSector As Range)
Dim Zelle As Range
For Each Zelle In rangeSector
If Zelle "" Then
If rangeListeB Is Nothing Then
rangeZielB = Zelle.Value
Set rangeListeB = rangeZielB
Else
With rangeListeB
Set rangeZielB = rangeZielB.Offset(0, 6)
rangeZielB.Value = Zelle.Value
Set rangeListeB = Union(rangeListeB, rangeZielB)
End With
End If
End If
Next
End Sub
'####Auslesen von allen ODM für Philips!####
Private Sub Bereich1_Auslesen(rangePhilips As Range)
Dim Zelle As Range, rangeGefunden As Range
For Each Zelle In rangePhilips
If Zelle "" Then
If rangeListe1 Is Nothing Then
rangeZiel1 = Zelle.Value
Set rangeListe1 = rangeZiel1
Else
With rangeListe1
Set rangeGefunden = .Find(what:=Zelle.Value, LookIn:=xlValues, Lookat:=xlWhole)
If rangeGefunden Is Nothing Then
Set rangeZiel1 = rangeZiel1.Offset(0, 1)
rangeZiel1 = Zelle.Value
Set rangeListe1 = Union(rangeZiel1, rangeListe1)
End If
End With
End If
End If
Next
End Sub
'####Auslesen von allen Philips-ODM für Pie-Liste!####
Private Sub Philips_Auspressen(rangeSector2 As Range)
Dim rangeGefunden As Range
Dim Zelle As Range
For Each Zelle In rangeSector2
If Zelle "" Then
If rangeListe2 Is Nothing Then
rangeZiel2 = Zelle.Value
Set rangeListe2 = rangeZiel2
Else
With rangeListe2
Set rangeZiel2 = rangeZiel2.Offset(1, 0)
rangeZiel2.Value = Zelle.Value
Set rangeListe2 = Union(rangeListe2, rangeZiel2)
End With
End If
End If
Next
Set rangeZiel2 = rangeZiel2.Offset(1, 0)
rangeZiel2 = Range("N70").Value
Set rangeListe2 = Union(rangeListe2, rangeZiel2)
End Sub
'###ODM-Pie-Werte für Philips Auslesen!###
Private Sub Philips_Ausquetschen(rangeSector3 As Range)
Dim Zelle As Range
For Each Zelle In rangeSector3
If Zelle.Value "" Then
If rangeListe2A Is Nothing Then
rangeZiel2A = Zelle.Offset(5, 0).Value
Set rangeListe2A = rangeZiel2A
Else
Set rangeZiel2A = rangeZiel2A.Offset(1, 0)
rangeZiel2A.Value = Zelle.Offset(5, 0).Value
Set rangeListe2A = Union(rangeListe2A, rangeZiel2A)
End If
End If
Next
Set rangeZiel2A = rangeZiel2A.Offset(1, 0)
rangeZiel2A.Value = Range("N71").Value
Set rangeListe2A = Union(rangeListe2A, rangeZiel2A)
End Sub
Sub Suchen(rngBereich, varSuchen, wks, ZielZeile, ZielSpalte)
Dim rngGefunden As Range
'Supplier im benannten Bereich suchen
Set rngGefunden = rngBereich.Find(what:=varSuchen, LookIn:=xlValues, Lookat:=xlWhole)
If Not rngGefunden Is Nothing Then
'Wert aus Spalte links von gefundener Zelle in Zielzelle eintragen
wks.Cells(ZielZeile, ZielSpalte).Value = rngGefunden.Offset(0, -1).Value
End If
End Sub
'Textbox mit ODM-Werten nach Auswahl in Listbox anzeigen
Private Sub ListBox1_Change()
Dim Cell As Range
With Me.ODMKeyCountVolume1
For Each Cell In Worksheets("Overview").Range("PhilipsODM")
If Cell.Value = ListBox1 Then
.Value = Cell.Offset(5, 0).Value
End If
Next
End With
End Sub