AW: Index schreiben
27.04.2012 01:03:12
fcs
Hallo Markus,
die nachfolgenden Makros erstellen eine Liste, in der jede Auftragsnummer nur einmal erscheint.
Gruß
Franz
'Code in einem allgemeinen Modul
Option Explicit
Private objCollection As Collection
Private arrAuftragNr() As Variant, lngNr As Long
Sub AuftragsNummern()
Dim wksZiel As Worksheet
Dim lngZeile As Long, rngAuftragNr As Range, rngZelle As Range
Set wksZiel = ActiveWorkbook.Worksheets("Gesamt")
Set objCollection = New Collection
lngNr = 0
'Im Blatt "Gesamt" schon vorhandene Nummern einlesen
If BlattAuswerten(strBlatt:="Gesamt", Zeile1:=2, SpalteAnr:=1) = False Then
MsgBox "Fehler beim Auswerten von Blatt ""Gesamt""", vbInformation, "Auftragsnummern"
End If
If BlattAuswerten(strBlatt:="Auftrag") = False Then
MsgBox "Fehler beim Auswerten von Blatt ""Auftrag""", vbInformation, "Auftragsnummern"
End If
If BlattAuswerten(strBlatt:="Bestellung") = False Then
MsgBox "Fehler beim Auswerten von Blatt ""Bestellung""", vbInformation, "Auftragsnummern"
End If
'AuftragsNrn im Blatt "Gesamt" eintragen
With wksZiel
'alte Liste löschen
lngZeile = .Cells(.Rows.Count, 1).End(xlUp).Row
If lngZeile = 1 Then
'do nothing
Else
Set rngAuftragNr = .Range(.Cells(2, 1), .Cells(lngZeile, 1))
rngAuftragNr.ClearContents
lngZeile = 1
End If
'Nummern in Liste eintragen
If lngNr > 0 Then
Application.ScreenUpdating = False
For lngNr = LBound(arrAuftragNr) To UBound(arrAuftragNr)
lngZeile = lngZeile + 1
.Cells(lngZeile, 1).Value = arrAuftragNr(lngNr)
Next
If lngZeile > 2 Then
'Auftragsnummern aufsteigend sortieren
Set rngAuftragNr = .Range(.Cells(2, 1), .Cells(lngZeile, 1))
With rngAuftragNr
.Sort key1:=.Range("A1"), order1:=xlAscending, Header:=xlNo
End With
End If
Application.ScreenUpdating = True
End If
End With
Erase arrAuftragNr
Set wksZiel = Nothing
Set objCollection = Nothing
End Sub
Private Function BlattAuswerten(strBlatt As String, _
Optional Zeile1 As Long = 2, Optional SpalteAnr As Long = 5) As Boolean
'Auftragsnummern im Blatt strBlatt in Array mit Auftragsnummern ergänzen
'strBlatt = Name des Blatt das ausgewertet werden soll
'Zeile1 = Nummer der Zeile ab der Auftragsnummern erfasst werden sollen
'SpalteAnr = Spalte im Blatt mit den Auftragsnummern
Dim wksQuelle As Worksheet
Dim varAuftragNr As Variant
Dim lngZeile As Long
On Error GoTo Fehler
BlattAuswerten = True
Set wksQuelle = ActiveWorkbook.Worksheets(strBlatt)
With wksQuelle
For lngZeile = Zeile1 To .Cells(.Rows.Count, SpalteAnr).End(xlUp).Row
varAuftragNr = .Cells(lngZeile, SpalteAnr).Value
objCollection.Add Item:=varAuftragNr, Key:=CStr(varAuftragNr)
lngNr = lngNr + 1
ReDim Preserve arrAuftragNr(1 To lngNr)
arrAuftragNr(lngNr) = varAuftragNr
NextZeile:
Next
End With
Fehler:
With Err
Select Case .Number
Case 0 'Alles ok
Case 457 'doppelter Schlüssel in Collection
'Auftragsnummer ist in Liste schon vorhanden
Resume NextZeile
Case Else
BlattAuswerten = False
End Select
End With
Set wksQuelle = Nothing
End Function