Materiallager-Listen, war: Ich brauche Hilfe bei einer Funktion

[Fox2k7]

Hallo liebe Community,

ich habe an meinem Arbeitsplatz nun mehr mit Excel zu tun und habe mal in der Vergangenheit Den Einstiegs und Fortgeschrittenen Workshop in Office 2010 gemacht.

Nun ist es schon etwas her und ich brauch hilfe bei einer Funktion.

Ich habe eine Lagerplatz Liste erstellt in der Firma in der Liste habe ich ein Lagerplatz vergeben und darunter die Materialnummern die auf diesem Lagerplatz liegen. Also ganz klassich denke ich.
Ich habe aber ein Paletten Regal mit dem Nachschub und ein Entnahme Regal wo sich die Materialnummern natürlich überschneiden.

Nun wollte ich eine weitere Tabelle erstellen auf der Mein Entnahme Regal und das Nachschubregal jeweils nebeneinander gelistet ist das man direkt sehen kann auf welchem Platz mein Material für den Nachschub liegt. Und falls sich in meiner Paletten Regal Liste ein Material umgelagert wird das es automatisch in meiner neuen Liste aktualisiert wird auf welchen Platz ich was umgelagert hab.

Versteht ihr was ich meine?

Wäre cool wenn ihr mir bischen auf die Sprünge helfen könntet.


Liebe Grüße

[Bamberg]

Servus Fox,

das kann eine lästige Arbeit sein, so eine Liste manuell aufzubauen. Aktuell bin ich mir nicht sicher, ob es eine Lösung mit Matrixformeln gibt und wie komplex so etwas werden würde, daher wäre meine Lösung in VBA.

Anbei der Code, den Du bitte in ein Modul kopierst ...

Code:

Option Explicit

Public Sub Aktualisieren()

   Dim Materialstandort As Variant
   
   Materialstandort = TransposeXXL(ThisWorkbook.Worksheets("Tabelle1").Range("D5:AE25")) 'Quelle: Tabellenname und Bereich anpassen
   
   If IsArray(Materialstandort) Then
       With ThisWorkbook.Worksheets("Tabelle2").Range("A1")    'Ausgabe: Tabellenname und Bereich anpassen
           .Parent.UsedRange.ClearContents                     'Tabellenblatt vor Ausgabe reinigen
           .Resize(UBound(Materialstandort, 1), UBound(Materialstandort, 2)).Value = Materialstandort
       End With
   End If

End Sub


Private Function TransposeXXL(ByVal Bereich As Range) As Variant
   
   Dim Materialstandort As Variant
   Dim i As Long, j As Long, l As Long, a As String
   Dim x As Long, y As Long
   Dim Quelle As Variant
   Dim Arr As Variant
   Dim Dic As Object, Eintrag As Variant
       
   Quelle = Bereich.Value
   
   Set Dic = CreateObject("Scripting.Dictionary")
   
   'Lagerplätze einlesen
   For i = LBound(Quelle, 1) + 1 To UBound(Quelle, 1)
       For j = LBound(Quelle, 2) To UBound(Quelle, 2)
           a = Trim(Quelle(i, j))
           If a <> "" Then ' leere Felder überspringen
               If Dic.exists(a) Then 'Falls Material schon vorhanden, Einträge erweitern
                   Arr = Dic(a)
                   l = UBound(Arr, 2) + 1
                   ReDim Preserve Arr(1 To 2, 1 To l)
                   Arr(1, l) = Quelle(1, j)
                   Arr(2, l) = i - 1
                   Dic(a) = Arr
                   If x < l Then x = l
               Else 'Falls Material nicht vorhanden, Einträge erzeugen
                   l = 1
                   ReDim Arr(1 To 2, 1 To 1)
                   Arr(1, l) = Quelle(1, j)
                   Arr(2, l) = i - LBound(Quelle, 1)
                   Dic(a) = Arr
                   If x < l Then x = l
                   y = y + 1
               End If
           End If
       Next j
   Next i
   
   ReDim Materialstandort(1 To y, 1 To x * 2 + 1)
   
   l = 0
   For Each Eintrag In Dic.Keys
       l = l + 1
       Materialstandort(l, 1) = Eintrag
       For i = LBound(Dic(Eintrag), 2) To UBound(Dic(Eintrag), 2)
           Materialstandort(l, i * 2) = Dic(Eintrag)(1, i)
           Materialstandort(l, i * 2 + 1) = Dic(Eintrag)(2, i)
       Next i
   Next Eintrag
   
   TransposeXXL = Materialstandort
   
   Set Dic = Nothing
   Set Eintrag = Nothing
   Set Arr = Nothing
   Set Quelle = Nothing
   Set Materialstandort = Nothing

End Function

... und die Namensanpassungen an Deine Arbeitsmappe vornimmst.
Die Prozedur "Aktualisieren" würde ich auf einen Button legen.
Für Deine Rückmeldung vielen Dank vorab.

LG Gerd