AW: Zln auf Filterbereich in array einlesen
04.04.2022 14:15:35
Siegie
Hallo Thorsten,
habe mich da mal zur Problemlösung weiter versucht und glaube so die Lösung dafür gefunden zu haben. Sollte bei einem Eintrag bereits die Zielwerte vergeben sein und nochmals ein Eintrag erfolgen, wird die Spalte "C" in gelb markiert, damit man sie anschließen nochmals mit je einem Zielwert kopieren kann.
Sollte es eine bessere Lösung geben, bin für jede Anregung bereit, man kann ja nie genug dazulernen, DANKE.
LG Siegfried
Sub Makro2()
Dim StartRow, EndRow, arr, Ende As Variant
Dim L_Arr As Long
Dim x, xa, y, ya As Integer
Lesen = Range("K2")
arr = Sheets("Ausw_KM").Range(Lesen) 'Einlesen
L_Arr = UBound(arr)
Ende = False
Sheets("Aufz").Select
StartRow = Range("U3:U1000").Cells.SpecialCells(xlCellTypeVisible)(1).Row
EndRow1 = ActiveSheet.Cells(Rows.Count, 21).End(xlUp).Row ' Spalte U
y = 3
For x = StartRow To EndRow1
If Rows(x).Height > 0 Then
Sheets("Ausw_KM").Range("A" & y) = Format(Range("U" & x), "dd.MM.YYYY")
Sheets("Ausw_KM").Range("A" & y).Font.Size = 8
Sheets("Ausw_KM").Range("B" & y) = Range("T" & x)
Sheets("Ausw_KM").Range("B" & y).Font.Size = 8
Sheets("Ausw_KM").Range("C" & y) = Range("R" & x)
Sheets("Ausw_KM").Range("C" & y).Font.Size = 8
y = y + 1
End If
Next x
Sheets("Ausw_KM").Select
Range("A1").Select
Call Makro2A
End Sub
Sub Makro2A()
Dim EndRow1, EndRow2, SuchWert, Lesen, x As Variant
Lesen = Range("K2")
arr = Range(Lesen) 'Einlesen
L_Arr = UBound(arr)
EndRow1 = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row ' Spalte A
EndRow2 = Range("K1") ' Spalte K - Entfernungsdaten
For xa = 1 To EndRow2
SuchWert = arr(xa, 1)
If ActiveSheet.AutoFilter.FilterMode Then ActiveSheet.AutoFilter.ShowAllData ' Datenbereich Fahrtziel
ActiveSheet.Range("A2:A150").AutoFilter Field:=3, Criteria1:="=*" & SuchWert & "*", Operator:=xlAnd
Call Sichtbare_Anz
AnfDat = Range("C3:C1000").Cells.SpecialCells(xlCellTypeVisible)(1).Row
EndDat = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
If Range("C1") > 0 Then
For x = AnfDat To EndDat
If Rows(x).Height > 0 Then
If Range("D" & x) "" Then Range("C" & x).Interior.ColorIndex = 6 'gelb
Range("D" & x) = arr(xa, 2)
Range("E" & x) = arr(xa, 3)
Range("F" & x) = arr(xa, 4)
End If
Next x
End If
Next xa
If ActiveSheet.AutoFilter.FilterMode Then ActiveSheet.AutoFilter.ShowAllData ' Datenbereich Fahrtziel
SortSpa = "E"
Call Makro2B
SortSpa = ""
End Sub
Sub Makro2B()
Dim EndRow As Variant
If SortSpa = "" Then SortSpa = "A"
EndRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row ' Spalte E ZielPerson
Range("A3:F" & EndRow).Select
ActiveWorkbook.Worksheets("Ausw_KM").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Ausw_KM").Sort.SortFields.Add2 Key:=Range( _
SortSpa & "3:" & SortSpa & EndRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
IIf(SortSpa = "A", xlSortTextAsNumbers, xlSortNormal)
With ActiveWorkbook.Worksheets("Ausw_KM").Sort
.SetRange Range("A3:F" & EndRow)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
SortSpa = ""
End Sub
