Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1260to1264
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Index schreiben

Index schreiben
Markus
Hallo,
in den Tabellen Auftrag und Bestellung sind in der Spalte E Auftragsnummern.
Alle diese Auftragsnummern möchte ich in die Tabelle Gesamt in die Spalte A schreiben.
Das "Schwere" daran ist, dass jede Auftragsnummer nur einmal geschrieben wird ab A2.
Wichtig: in den Tabellen Auftrag und Bestellung gibt es verschiedene Zeilen, bei denen in der Spalte E noch nichts steht (blank).
In den Tabellen Auftrag und Bestellung sind jeweils maximal 200 Zeilen geschrieben.
Markus

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Index schreiben
26.04.2012 23:36:27
Reinhard
Hallo Markus,
Option Explicit
Sub Gesamt()
Dim colC As New Collection, Zei As Long
Call Blatt(Worksheets("Auftrag"), colC)
Call Blatt(Worksheets("Bestellung"), colC)
With Worksheets("Gesamt")
For Zei = 1 To colC.Count
.Cells(Zei, 1).Value = colC(Zei)
Next Zei
End With
End Sub
Sub Blatt(ByRef wks As Worksheet, colC As Collection)
Dim Zei As Long
On Error Resume Next
With wks
For Zei = 2 To .Cells(Rows.Count, 5).End(xlUp).Row
colC.Add Item:=CStr(.Cells(Zei, 5).Value), key:=CStr(.Cells(Zei, 5).Value)
Next Zei
End With
End Sub

Gruß
Reinhard
Anzeige
AW: Index schreiben
27.04.2012 00:11:15
Markus
Hallo Reinhard,
fast perfekt!
Es wird immer noch eine Zeile für den "blank" erstellt.
Markus
AW: Index schreiben
27.04.2012 00:11:22
Markus
Hallo Reinhard,
fast perfekt!
Es wird immer noch eine Zeile für den "blank" erstellt.
Markus
AW: Index schreiben
27.04.2012 01:19:19
Reinhard
Hallo Markus,
Sub Blatt(ByRef wks As Worksheet, colC As Collection)
Dim Zei As Long
On Error Resume Next
With wks
For Zei = 2 To .Cells(Rows.Count, 5).End(xlUp).Row
If .Cells(Zei, 5).Value  " " Then
colC.Add Item:=CStr(.Cells(Zei, 5).Value), key:=CStr(.Cells(Zei, 5).Value)
End If
Next Zei
End With
End Sub

Gruß
Reinhard
AW: Index schreiben
27.04.2012 01:36:23
Reinhard
Hallo Markus,
vllt. besser so:
Sub Blatt(ByRef wks As Worksheet, colC As Collection)
Dim Zei As Long
On Error Resume Next
With wks
For Zei = 2 To .Cells(Rows.Count, 5).End(xlUp).Row
If Replace(.Cells(Zei, 5).Value, " ")  "" Then
colC.Add Item:=CStr(.Cells(Zei, 5).Value), key:=CStr(.Cells(Zei, 5).Value)
End If
Next Zei
End With
End Sub

Gruß
Reinhard
Anzeige
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

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige