in 1. post falsche Datei - sorry
02.03.2006 22:27:42
Stefan
hier der richtige anhang: https://www.herber.de/bbs/user/31589.xls
und noch der code:
Option Explicit
Sub BenutzerAuswählen()
Generieren 0, True
End Sub
Sub Generieren(intEmpfänger As Integer, bolAuswahlZeigen As Boolean)
Dim strZelle As String
Dim intLänge As Integer
Dim strReports As String
Dim intAuswahl As Integer
If bolAuswahlZeigen Then
DialogSheets("Choose_Benutzer").Show
intEmpfänger = DialogSheets("Choose_Benutzer").ListBoxes("Liste").ListIndex
End If
Application.ScreenUpdating = False
Application.Calculation = xlManual
If intEmpfänger Then
Dim i%
Dim Spalte_Ziel%
Dim Spalte_Quell%
Dim Spalte_Hier%
Spalte_Quell = 2
Spalte_Ziel = 2
Spalte_Hier = 2
Sheets("Ziel").Range("B2:IV10000").ClearContents
Do
Spalte_Hier = 2
Do
If Sheets("Hier").Cells(2, Spalte_Hier) = Sheets("Quell").Cells(intEmpfänger + 1, Spalte_Quell) Then
Worksheets("Ziel").Activate 'ist erforderlich, weil gleich Verknüpfungen eingefügt werden sollen
For i = 2 To 5 'hier kannst du die Anzahl der Zeilen festlegen, die ein Jahresdatensatz hat
Sheets("Hier").Cells(i, Spalte_Hier).Copy
With Worksheets("Ziel")
.Cells(i, Spalte_Ziel).Select
.Paste 'fügt erst einmal komplett alles ein
.Paste Link:=True 'ersetzt die Einträge durch entsprechende Links(Verweise) auf die Hier-Zelle
End With
Next i
Spalte_Ziel = Spalte_Ziel + 1
Exit Do
End If
Spalte_Hier = Spalte_Hier + 1
Loop Until Sheets("Hier").Cells(2, Spalte_Hier) = "" 'hier wird das Jahr in deiner Liste "Hier" gesucht bis nach rechts nichts mehr steht.
Spalte_Quell = Spalte_Quell + 1
Loop Until Sheets("Quell").Cells(intEmpfänger + 1, Spalte_Quell) = "" 'hier wird solange durchgearbeitet bis in deiner Benutzertabelle keine Jahre rechts rüber mehr auftauchen
End If
Application.Calculation = xlAutomatic
End Sub