|
Hallo Tutti,
erstmal danke für die schnelle Antwort. Das ist nicht ganz das, was ich suche.
Mein Organigramm sieht quasi so aus:
(TL = Teamleiter, MA = Mitarbeiter des jeweiligen Teams)
Spalte A Spalte B Spalte C ...
TL TL TL
(Leer) (Leer) (Leer)
MA1 (Leer) (Leer)
(Leer) MA 1 (Leer)
(Leer) (Leer) MA1
(Leer) MA2 (Leer)
MA2 (Leer) (Leer)
Der Code sieht folgendermaßen aus:
Sub CreateOrgChart()
Dim i As Integer, j As Integer, y As Integer
Dim LastRow As Long, LastLine As Long
'Letzte Zeile in Spalte G (7) ermitteln
With ActiveSheet
LastRow = .Range("A1").SpecialCells(xlCellTypeLastCell).Row - 3
End With
'Bildschirmwechsel aus
Application.ScreenUpdating = True
'Zuweisung der Rollen
Sheets(1).Select
'Zuordnung der Mitarbeiter (MA) im Organigramm zu den jeweiligen Teamleitern
Sheets(1).Select
y = 14
For i = 2 To LastRow
If Sheets(1).Cells(i, 7).Value = "MA" And Sheets(1).Cells(i, 8).Value = "Volker Aichele" Then
Range(Cells(i, 3), Cells(i, 4)).Copy
Sheets(2).Cells(y + 1, 4).PasteSpecial Paste:=xlPasteValues '-->Fügt in Zeile ais "Kontakte" + y ein...
End If
If Sheets(1).Cells(i, 7).Value = "MA" And Sheets(1).Cells(i, 8).Value = "Marco Marquart" Then
Range(Cells(i, 3), Cells(i, 4)).Copy
Sheets(2).Cells(y + 1, 7).PasteSpecial Paste:=xlPasteValues
End If
If Sheets(1).Cells(i, 7).Value = "MA" And Sheets(1).Cells(i, 8).Value = "Daniel Leppert" Then
Range(Cells(i, 3), Cells(i, 4)).Copy
Sheets(2).Cells(y + 1, 10).PasteSpecial Paste:=xlPasteValues
End If
If Sheets(1).Cells(i, 7).Value = "MA" And Sheets(1).Cells(i, 8).Value = "Elena Weccard" Then
Range(Cells(i, 3), Cells(i, 4)).Copy
Sheets(2).Cells(y + 1, 13).PasteSpecial Paste:=xlPasteValues
End If
If Sheets(1).Cells(i, 7).Value = "MA" And Sheets(1).Cells(i, 8).Value = "Salvatore Oliverio" Then
Range(Cells(i, 3), Cells(i, 4)).Copy
Sheets(2).Cells(y + 1, 16).PasteSpecial Paste:=xlPasteValues
End If
If Sheets(1).Cells(i, 7).Value = "MA" And Sheets(1).Cells(i, 8).Value = "Giuseppe Oliverio" Then
Range(Cells(i, 3), Cells(i, 4)).Copy
Sheets(2).Cells(y + 1, 19).PasteSpecial Paste:=xlPasteValues
End If
If Sheets(1).Cells(i, 7).Value = "MA" And Sheets(1).Cells(i, 8).Value = "Dennis Pfeffer" Then
Range(Cells(i, 3), Cells(i, 4)).Copy
Sheets(2).Cells(y + 1, 22).PasteSpecial Paste:=xlPasteValues
End If
If Sheets(1).Cells(i, 7).Value = "MA" And Sheets(1).Cells(i, 8).Value = "Hauke Tiedemann" Then
Range(Cells(i, 3), Cells(i, 4)).Copy
Sheets(2).Cells(y + 1, 25).PasteSpecial Paste:=xlPasteValues
End If
y = y + 1
Next i
End Sub
Ich habe somit NIE eine komplett leere Zeile, deshalb muss ich die einzelnen ZELLEN in der jeweiligen Spalte löschen...
Hab nach mehrfachem umstellen des Codes noch die Variante, dass er mir alles in eine Zeile schreibt und damit nur die jeweils letzten Mitarbeiter aus der Liste einträgt...
Hab mittlerweile ermmittelt:
Wenn in Tab1 ein MA in Zeilenummer 300 steht, wird dieser kopiert, der richtigen Spalte zugeordnet und in Zeile 300 + Y eingefügt (?)
Im Optimalfall sollte er die Mitarbeiter gleich so reinkopiert werden:
Spalte A Spalte B Spalte C ...
TL TL TL
MA1 MA1 MA1
MA2 MA2 MA2
MA3 MA3 MA3
... ... ...
Ich krieg es bis dato nicht hin :(
Für eure Hilfe dankt,
Heiko
|