Artikelzuordnung

Die Datei https://www.herber.de/bbs/user/33757.xls wurde aus Datenschutzgründen gelöscht

Schönen Nachmittag,
ich habe ein riesen Problem und hoffe mir kann jemand helfen. Ich habe extra ein Test File beigefügt an dem man mein Problem erkennen kann.
In der Spalte A stehen bei mir Artikel und in den Spalten b und c Baugruppen. Ich muss jetzt in Spalte d zuerst einmal alle Baugruppen aus den Spalten b und c untereinander schreiben ohne das dabei eine Baugruppe doppelt angezeigt wird wird. Anschließend benötige ich eine Zuordnung die mir anzeigt welche Artikel alle aus den einzelnen Baugruppen bestehen. Also z.B. Baugruppe ab besitzt die Artikel 1 4 7 13 usw. Baugruppe cde die Artikel 2 5 8 usw.
Kann mir jemand dabei helfen.
Danke

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub Umkehren1() Dim zB As Long, sB As Integer, zE1 As Long, zE As Long, zEv As Long, ss As Integer zE1 = 15 Cells(zE1, 4) = Cells(3, 2) Cells(zE1, 5) = Cells(3, 1) zE = zE1 For sB = 2 To 3 For zB = 6 - sB To Cells(Rows.Count, sB).End(xlUp).Row For zEv = zE1 To zE If Cells(zB, sB) = Cells(zEv, 4) Then Cells(zEv, 5) = Cells(zEv, 5) & "," & Cells(zB, 1) Exit For End If Next zEv If zEv > zE Then zE = zE + 1 Cells(zE, 4) = Cells(zB, sB) Cells(zE, 5) = Cells(zB, 1) End If Next zB Next sB End Sub Sub Umkehren2() Dim zB As Long, sB As Integer, zE1 As Long, zE As Long, zEv As Long, ss As Integer zE1 = 25 zE = zE1 Cells(zE1, 4) = Cells(3, 2) Cells(zE1, 5) = Cells(3, 1) Range(Cells(zE, 6), Cells(zE, 256)).ClearContents For sB = 2 To 3 For zB = 6 - sB To Cells(Rows.Count, sB).End(xlUp).Row For zEv = zE1 To zE If Cells(zB, sB) = Cells(zEv, 4) Then Cells(zEv, Cells(zEv, Columns.Count).End(xlToLeft).Column + 1) = Cells(zB, 1) Exit For End If Next zEv If zEv > zE Then zE = zE + 1 Cells(zE, 4) = Cells(zB, sB) Cells(zE, 5) = Cells(zB, 1) Range(Cells(zE, 6), Cells(zE, 256)).ClearContents End If Next zB Next sB End Sub

Option Explicit Sub ZordnungUmkehren() Dim sB As Integer, zE As Long, zB As Long, zV As Long ' Const zE1 = 1, sE = 1, zB1 = 3, sB1 = 2, sB2 = 3, komma = True ' With Sheets(2) Const zE1 = 18, sE = 4, zB1 = 3, sB1 = 2, sB2 = 3, komma = False With Sheets(1) Range(.Cells(zE1, sE), .Cells(Rows.Count, Columns.Count)).ClearContents If komma Then .Columns(sE + 1).NumberFormat = "@" Else .Columns(sE + 1).NumberFormat = "General" End If zE = zE1 - 1 For sB = sB1 To sB2 For zB = zB1 - (sB <> sB1) To Cells(Rows.Count, sB).End(xlUp).Row If Cells(zB, sB) <> "0" Then ' neu For zV = zE1 To zE If .Cells(zV, sE) = Cells(zB, sB) Then If komma Then .Cells(zV, sE + 1) = .Cells(zV, sE + 1) & "," & Cells(zB, 1) Else .Cells(zV, .Cells(zV, Columns.Count).End(xlToLeft).Column + 1) = _ Cells(zB, 1) End If Exit For End If Next zV If zV > zE Then zE = zE + 1 .Cells(zE, sE) = Cells(zB, sB) .Cells(zE, sE + 1) = Cells(zB, 1) End If End If ' neu Next zB Next sB End With End Sub

Hallo Ralph,
ein wenig deutlicher wird die Rolle der Konstanten, wo du jetzt auch die Spalte mit den Artikeln festlegen kannst, damit:

   Sub ZordnungUmkehren()
Dim sB As Integer, sE As Integer, zB As Long, zV As Long, zE As Long
Const zA = 3, zE1 = 9, komma = False      ' 1. Zeile von Artikel, Ergebnis
'  (jeweils Zeilennummer der Überschrift)
Const sA = 1, sB1 = 2, sB2 = 5, sEe = 7   ' Spalte(n) Artikel, Bauteile, Ergebnis
Const komma = False                       ' Darstellung mit Komma oder einzeln
With Sheets(1)                            ' Blatt für Ergebnis
If .Name = ActiveSheet.Name Then _
sE = IIf(sEe <= sB2, sB2 + 1, sEe): sE = IIf(sE <= sA, sA + 1, sE)
Range(.Cells(zE1, sE), .Cells(Rows.Count, Columns.Count)).ClearContents
zE = zE1 - 1
For sB = sB1 To sB2
For zB = zA - (sB <> sB1) To Cells(Rows.Count, sB).End(xlUp).Row
If Not IsEmpty(Cells(zB, sB)) And Cells(zB, sB) <> "0" Then    ' ohne 0, leer
For zV = zE1 To zE
If .Cells(zV, sE) = Cells(zB, sB) Then
If komma Then
.Cells(zV, sE + 1) = .Cells(zV, sE + 1) & "," & Cells(zB, sA)
Else
.Cells(zV, .Cells(zV, Columns.Count).End(xlToLeft).Column + 1) _
= Cells(zB, sA)
End If
Exit For
End If
Next zV
If zV > zE Then
zE = zV     ' = zE + 1
.Cells(zE, sE) = Cells(zB, sB):  .Cells(zE, sE + 1) = Cells(zB, sA)
End If
End If                                                         ' ohne 0, leer
Next zB
Next sB
.Columns(sE).Rows(zE1 & ":" & zE).NumberFormat = "@"
.Columns(sE + 1).Rows(zE1 & ":" & zE).NumberFormat = IIf(komma, "@", "General")
End With
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Beliebteste Forumthreads (12 Monate)

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread