|
Hallo, in das folgende Makro habe ich viele Programmteile integriert, die mir freundlicherweise VBA Provis in diesem Forum bereitgestellt haben. Ich habe eine Ziel -und eine Quelldatei. In der Zieldatei habe ich 2 Module. Ein Modul, das mir Zugänge nach Jahresausauswahl ausgibt (siehe Anhang), ein ähnliches Modul, für Abgänge nach Jahresauswahl und ein drittes würde ich gerne mit Eurer Hilfe erstellen. In der Quelldatei in der Spalte AC habe ich die Zugangsdaten, in Spalte AQ die Abgangsdaten. Ich würde gerne das Makro so abändern, dass man bei der Datumsauswahl alle Namen erhält, die zu diesem Datum aktive Mitglieder waren. Die Spalte AC beginnt beim Jahr 2000. Wahrscheinlich müsste die Suchschleife alle Jahre vom Suchdatum bis zum Anfangsdatum aus der Spalte AC auswählen und die Abgänge aus der Spalte AQ in diesem Zeitraum abziehen. Leider kann ich das nicht programmieren. Das wäre der Hammer, wenn Ihr mir da weiterhelfen könntet. Vielen Dank schon mal!!! Gruß David
Option Explicit
Public Objekt_Finden As Object
Public sArr() As String, sBer() As String
Public Spalte_ErsteAdresse As String, Spalte_Suchen As String
Public i As Integer, n As Integer, Ausgabe_Zeile As Long
Sub Zugang_Jahr()
Dim Ziel As Worksheet, Quelle As Worksheet
Const csSpalten = "A1,F1,B1,C1,T1,AC1,AQ1,AA1,V1,U1,AH1,AI1,BE1,E1"
Workbooks.Open Pfad, Password:=xxxxxx
Set Quelle = Worksheets("Datenerfassung")
Set Ziel = ThisWorkbook.Worksheets("Zugang Jahr")
sArr = Split(csErsetz, ",")
sBer = Split(csSpalten, ",")
' <<< Daten in Zieldatei löschen >>>
Ziel.Range("A11:N60").ClearContents
Ziel.Range("A11:N60").Interior.ColorIndex = xlNone
' <<< Spalten grau füllen >>>
Ziel.Range("B11:B60").Interior.Color = RGB(217, 217, 217)
' <<< Schriftfarbe festlegen >>>
Ziel.Range("C11:C60").Font.ColorIndex = 1
' <<< Datumsausgabe nur als Jahr >>>
Quelle.Range("AC:AC").NumberFormat = "YYYY"
' <<< Text aus Zelle als Suchbegriff festlegen >>>
Spalte_Suchen = Ziel.Range("K4").Value
If Spalte_Suchen = "" Then Exit Sub
' <<< Erste Ausgabezeile in der Zieldatei >>>
Ausgabe_Zeile = 12
' <<< Erstes Feld mit dem Suchbegriff suchen >>>
Set Objekt_Finden = Quelle.Range("AC:AC").Find(Spalte_Suchen, LookIn:=xlValues, LookAt:=xlWhole)
If Not Objekt_Finden Is Nothing Then
Spalte_ErsteAdresse = Objekt_Finden.Address
Do
Ausgabe_Zeile = Ausgabe_Zeile + 1
For n = 0 To UBound(sBer)
' <<< Nur Werte >>>
Ziel.Cells(Ausgabe_Zeile, n + 1).Value _
= Quelle.Range(Replace(sBer(n), "1", Objekt_Finden.Row)).Value
Next n
' <<< Ersetze Begriffe vom Quellblatt im Zielblatt >>>
With Ziel.Cells(Ausgabe_Zeile, "J")
For i = 0 To UBound(sArr) - 1 Step 2
.Value = Replace(.Value, sArr(i), sArr(i + 1))
Next i
End With
' <<< Schleife für nächsten Suchbegriff >>>
Set Objekt_Finden = Quelle.Range("AC:AC").FindNext(Objekt_Finden)
Loop While Not Objekt_Finden Is Nothing And Objekt_Finden.Address <> Spalte_ErsteAdresse
End If
' <<< Sortieren >>>
Ziel.Range("A6:N" & Rows.Count).Sort Key1:=Ziel.Range("A6"), Order1:=xlDescending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
' <<< Farbverläufe festlegen >>>
Dim Zelle As Range
For Each Zelle In Ziel.Range("M:M")
If Zelle.Value = "München" Then
Zelle.Interior.Pattern = xlPatternLinearGradient
Zelle.Font.ColorIndex = 1
Zelle.Interior.Gradient.Degree = 180
Zelle.Interior.Gradient.ColorStops.Clear
Zelle.Interior.Gradient.ColorStops.Add(0).Color = RGB(255, 255, 255)
Zelle.Interior.Gradient.ColorStops.Add(1).Color = RGB(255, 192, 0)
Zelle.Offset(0, -10).Interior.Pattern = xlPatternLinearGradient
Zelle.Offset(0, -10).Font.ColorIndex = 1
Zelle.Offset(0, -10).Interior.Gradient.Degree = 180
Zelle.Offset(0, -10).Interior.Gradient.ColorStops.Clear
Zelle.Offset(0, -10).Interior.Gradient.ColorStops.Add(0).Color = RGB(255, 255, 255)
Zelle.Offset(0, -10).Interior.Gradient.ColorStops.Add(1).Color = RGB(255, 192, 0)
ElseIf Zelle.Value = "Erding" Then
Zelle.Interior.Pattern = xlPatternLinearGradient
Zelle.Font.ColorIndex = 2
Zelle.Interior.Gradient.Degree = 180
Zelle.Interior.Gradient.ColorStops.Clear
Zelle.Interior.Gradient.ColorStops.Add(0).Color = RGB(255, 255, 255)
Zelle.Interior.Gradient.ColorStops.Add(1).Color = RGB(112, 48, 160)
Zelle.Offset(0, -10).Interior.Pattern = xlPatternLinearGradient
Zelle.Offset(0, -10).Font.ColorIndex = 2
Zelle.Offset(0, -10).Interior.Gradient.Degree = 180
Zelle.Offset(0, -10).Interior.Gradient.ColorStops.Clear
Zelle.Offset(0, -10).Interior.Gradient.ColorStops.Add(0).Color = RGB(255, 255, 255)
Zelle.Offset(0, -10).Interior.Gradient.ColorStops.Add(1).Color = RGB(112, 48, 160)
ElseIf Zelle.Value = "Freising" Then
Zelle.Interior.Pattern = xlPatternLinearGradient
Zelle.Font.ColorIndex = 2
Zelle.Interior.Gradient.Degree = 180
Zelle.Interior.Gradient.ColorStops.Clear
Zelle.Interior.Gradient.ColorStops.Add(0).Color = RGB(255, 255, 255)
Zelle.Interior.Gradient.ColorStops.Add(1).Color = RGB(47, 117, 181)
Zelle.Offset(0, -10).Interior.Pattern = xlPatternLinearGradient
Zelle.Offset(0, -10).Font.ColorIndex = 2
Zelle.Offset(0, -10).Interior.Gradient.Degree = 180
Zelle.Offset(0, -10).Interior.Gradient.ColorStops.Clear
Zelle.Offset(0, -10).Interior.Gradient.ColorStops.Add(0).Color = RGB(255, 255, 255)
Zelle.Offset(0, -10).Interior.Gradient.ColorStops.Add(1).Color = RGB(47, 117, 181)
End If
Next Zelle
' <<< Satmmdaten schließen und zurück zur Zieldatei >>>
Workbooks("Stammdaten.xlsx").Close savechanges:=False
Ziel.Activate
End Sub
|