Makro anpassen

Sub KennzeichenAuslesen() Worksheets("Daten").Range("A7:C5230").ClearContents b = 6 'Zeilenbeginn wo geschrieben For y = 1 To 31 For a = 7 To 172 'lesen von bis If Worksheets(y).Range("E" & a) = "" Then a = 172 ' Abbruch wenn Zelle leer If Worksheets(y).Range("E" & a) > "" Then ' von wo ausgelesen wird b = b + 1 ' Teil 1 SchreibRoutine - Teil 2 LeseRoutine Worksheets("Daten").Range("A" & b) = Worksheets(y).Range("E" & a) 'Kennz Worksheets("Daten").Range("B" & b) = Worksheets(y).Range("M" & a) 'MAX Worksheets("Daten").Range("C" & b) = Worksheets(y).Range("Q" & a) 'IST End If Next a Next y 'Sortieren ab A7 bis C5320 'ActiveSheet.Range("A7:C5320").Select 'Selection.Sort Key1:=ActiveSheet.Range("A7"), Order1:=xlAscending, Header:=xlGuess 'Sortieren ab E7 bis E5320 'ActiveSheet.Range("E7:E5320").Select ' Selection.Sort Key1:=ActiveSheet.Range("E7"), Order1:=xlAscending, Header:=xlGuess Range("B8").Select 'Cursor setzen End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Moin Wafi,
ich hoffe du arbeitest nicht in Flensburg und richtest über unser aller Punkte ;-)
Aber so könnte es gehen, habe ich noch in meinen alten Beispielen gefunden.
Option Explicit


Public Sub KennzeichenAuslesen()
Dim intY As Integer, intA As Integer, intB As Integer
Dim arrKennzeichen As Variant
Worksheets("Daten").Range("A7:C5230").ClearContents
intB = 6 'Zeilenbeginn wo geschrieben
For intY = 1 To 2
For intA = 7 To 172 'lesen von bis
If Worksheets(intY).Range("E" & intA) = "" Then intA = 172 ' Abbruch wenn Zelle leer
If Worksheets(intY).Range("E" & intA) > "" Then ' von wo ausgelesen wird
intB = intB + 1
Worksheets("Daten").Range("A" & intB) = Worksheets(intY).Range("E" & intA) 'Kennz
Worksheets("Daten").Range("B" & intB) = Worksheets(intY).Range("M" & intA) 'MAX
Worksheets("Daten").Range("C" & intB) = Worksheets(intY).Range("Q" & intA) 'IST
End If
Next intA
Next intY
arrKennzeichen = Sortierte_Unikate(Range("A7:A5230"))
' Das End der Liste in A könnte man natürlich auch flexibel gestalten.
Worksheets("Daten").Range("E1").Resize(UBound(arrKennzeichen)) = arrKennzeichen
Range("B8").Select 'Cursor setzen
End Sub


Public Function Sortierte_Unikate(rngVonWo As Range) As Variant
Dim objDic As Object
Dim vntIn As Variant
Dim L As Long
Dim vntOut As Variant
vntIn = rngVonWo.Value
Set objDic = CreateObject("Scripting.Dictionary")
For L = LBound(vntIn) To UBound(vntIn)
objDic(CStr(vntIn(L, 1))) = 0
Next
vntOut = objDic.keys
QuickSort vntOut
Sortierte_Unikate = WorksheetFunction.Transpose(vntOut)
Set objDic = Nothing
End Function


Public Sub QuickSort(vSort As Variant, _
Optional ByVal lngStart As Variant, _
Optional ByVal lngEnd As Variant)
If IsMissing(lngStart) Then lngStart = LBound(vSort)
If IsMissing(lngEnd) Then lngEnd = UBound(vSort)
Dim i As Long
Dim j As Long
Dim h As Variant
Dim x As Variant
i = lngStart: j = lngEnd
x = vSort((lngStart + lngEnd) / 2)
Do
While (vSort(i)  x): j = j - 1: Wend
If (i  j)
If (lngStart

Gruß Heiko

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread