Frage stellen

Zuordnungen einer Materialnummer mit Makro in Zelle schreiben

196 Aufrufe
Gefragt in Tabellenkalkulation von

Hallo,

ich weiß nicht wie ich mein Vorhaben erklären soll, darum fange ich ganz simpel an.

In meinem Beispiel habe ich 3 Spalten die ich im Makro definieren will, hier im anonymisierten Beispiel die Spalte 1 für den Bereich und die Spalte 2 für die MatNr sowie 3 für die Ausgabe des ganzen ermittelten.

Es ist vorab wichtig, diese Spalten zu definieren, da in der Original-Liste es 25 Spalten gibt.

Das Makro sollte mir Zeile für Zeile abarbeiten und in der Ausgabe (Spalte C hier) die Zuordnungen auflisten, in welchem Bereich die MatNr überall vorkommt getrennt durch einen Strichpunkt (;).

Meine Liste ist zwar sehr lange, aber strukturiert aufgebaut, also erste Zeile ist die Überschrift und bis zum Ende gibt es keine Leerzeilen.

Kann mir hier bitte jemand helfen?

Danke!!

lg 

Lukas

7 Antworten

0 Punkte
Beantwortet von beverly_ Experte (3.3k Punkte)

Hi Lukas,

versuche es mal so:

Sub Zuordnung()
    Dim objDic As Object
    Dim Bereich As Variant
    Dim lngLetzte As Long
    Dim lngZeile As Long
    Dim lngZaehler As Long
    Dim rngZelle As Range
    Dim arrDaten As Variant
    Dim blnFilter As Boolean
    Set objDic = CreateObject("Scripting.Dictionary")
    lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
    Bereich = Range("B2", Range("B2").End(xlDown))
    For lngZeile = LBound(Bereich) To UBound(Bereich)
        objDic(Bereich(lngZeile, 1)) = 0
    Next
    arrDaten = objDic.keys
    If Not ActiveSheet.AutoFilterMode Then
        Range("A1").CurrentRegion.AutoFilter
    Else
        blnFilter = True
    End If
    For lngZaehler = LBound(arrDaten) To UBound(arrDaten)
        Range("A1").CurrentRegion.AutoFilter field:=2, Criteria1:=arrDaten(lngZaehler)
        For lngZeile = 2 To lngLetzte
            If Cells(lngZeile, 1).EntireRow.Height > 0 Then
                For Each rngZelle In Range("A2:A" & lngLetzte).SpecialCells(xlCellTypeVisible)
                    If rngZelle <> Cells(lngZeile, 1) Then
                        If InStr(Cells(lngZeile, 3), rngZelle) = 0 Then Cells(lngZeile, 3) = Cells(lngZeile, 3) & ";" & rngZelle
                    End If
                Next rngZelle
                Cells(lngZeile, 3) = Mid(Cells(lngZeile, 3), 2)
            End If
        Next lngZeile
    Next lngZaehler
    If blnFilter = False Then Range("A1").CurrentRegion.AutoFilter
End Sub

Bis später, Karin

0 Punkte
Beantwortet von
Hallo Karin,

danke danke danke für deinen Code.

Der funktioniert schon super, jedoch ist mir aufgefallen, dass ich einen Fehler in der Angabe gemacht habe.

In der ersten Zeile wird jetzt ja aufgezeigt, dass die MatNr auch in BBB,CCC zugeordnet ist.
Richtigerweise müsste da aber AAA;BBB;CCC stehen, also immer der Gesamte Bereich, wo die MatNr vorkommt.

Die Sortierung dabei ist egal, hauptsache alle 3 in dem Fall stehen dann in einem Feld.

lg

Lukas
0 Punkte
Beantwortet von
Hallo nochmals,

eine unverschämte Zusatzfrage, kann man die Spalten so definieren, dass man die einfach ändern kann?

Spalte Bereich = 1
Spalte MatNr = 2
Spalte Ausgabe = 3

Danke dir!
0 Punkte
Beantwortet von beverly_ Experte (3.3k Punkte)

Hi Lukas,

zuerst einmal zu dem Problem, dass alle MatNr eingetragen werden - ändere dazu den Code wie folgt:

    For lngZaehler = LBound(arrDaten) To UBound(arrDaten)
        Range("A1").CurrentRegion.AutoFilter field:=2, Criteria1:=arrDaten(lngZaehler)
        For lngZeile = 2 To lngLetzte
            If Cells(lngZeile, 1).EntireRow.Height > 0 Then
                For Each rngZelle In Range("A2:A" & lngLetzte).SpecialCells(xlCellTypeVisible)
                    If InStr(Cells(lngZeile, 3), rngZelle) = 0 Then Cells(lngZeile, 3) = Cells(lngZeile, 3) & ";" & rngZelle
                Next rngZelle
                Cells(lngZeile, 3) = Mid(Cells(lngZeile, 3), 2)
            End If
        Next lngZeile
    Next lngZaehler

Nun zu deinem zweiten Problem: was meinst du damit, dass man die Spalten ändern kann?

Bis später, Karin

0 Punkte
Beantwortet von

Hallo Karin,

danke für die Adaptierung funktioniert wunderbar!

jetzt muss ich das natürlich auf meine Tabelle übertragen und da habe ich das Problem, dass die Spalten anders verteilt sind.

Daher würde es Sinn ergeben, wenn am Anfang vom Makro die Spalten definiert sind.

Spalte Bereich = 1
Spalte MatNr = 2
Spalte Ausgabe = 3

Im Beispiel ist die Ausgabe in Spalte 3, das ganze Makro ist so aufgebaut.

In meiner Datei ist die Ausgabespalte jedoch die 26. Spalte. Jetzt muss ich das im ganzen Makro ändern, und darf nix vergessen. das ganze bei allen 3 Spaltenangaben,...

Macht es nicht Sinn, das Anfangs einmal zu definieren?

0 Punkte
Beantwortet von beverly_ Experte (3.3k Punkte)

Hi Lukas,

der folgende Code sucht zuerst in Zeile 1 die Zellen mit den Begriffen "Bereich", "MatNr" und "Ausgabe" und schreibt sie jeweils auf die betreffende Variable. Im weiteren Verlauf des Codes wird dann die Spaltennummer der gefundenen Zelle (Spaltennummer der jeweilgen Variablen) verwendet:

Sub Zuordnung()
    Dim objDic As Object
    Dim Bereich As Variant
    Dim lngLetzte As Long
    Dim lngZeile As Long
    Dim lngZaehler As Long
    Dim rngZelle As Range
    Dim arrDaten As Variant
    Dim blnFilter As Boolean
    Dim rngBereich As Range
    Dim rngMatNr As Range
    Dim rngAusgabe As Range
    Set rngBereich = Rows(1).Find("Bereich", lookat:=xlWhole) '<== Zelle suchen in der "Bereich" steht
    Set rngMatNr = Rows(1).Find("MatNr", lookat:=xlWhole)     '<== Zelle suchen in der "MatNr" steht
    Set rngAusgabe = Rows(1).Find("Ausgabe", lookat:=xlWhole) '<== Zelle suchen in der "Ausgabe" steht
    Set objDic = CreateObject("Scripting.Dictionary")
    lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
    Bereich = Range(Cells(2, rngMatNr.Column), Cells(2, rngMatNr.Column).End(xlDown))
    For lngZeile = LBound(Bereich) To UBound(Bereich)
        objDic(Bereich(lngZeile, 1)) = 0
    Next
    arrDaten = objDic.keys
    If Not ActiveSheet.AutoFilterMode Then
        Range("A1").CurrentRegion.AutoFilter
    Else
        blnFilter = True
    End If
    For lngZaehler = LBound(arrDaten) To UBound(arrDaten)
        Range("A1").CurrentRegion.AutoFilter field:=rngMatNr.Column, Criteria1:=arrDaten(lngZaehler)
        For lngZeile = 2 To lngLetzte
            If Cells(lngZeile, 1).EntireRow.Height > 0 Then
                For Each rngZelle In Range(Cells(2, rngBereich.Column), Cells(lngLetzte, rngBereich.Column)).SpecialCells(xlCellTypeVisible)
                    If InStr(Cells(lngZeile, rngAusgabe.Column), rngZelle) = 0 Then Cells(lngZeile, rngAusgabe.Column) = Cells(lngZeile, rngAusgabe.Column) & ";" & rngZelle
                Next rngZelle
                Cells(lngZeile, rngAusgabe.Column) = Mid(Cells(lngZeile, rngAusgabe.Column), 2)
            End If
        Next lngZeile
    Next lngZaehler
    If blnFilter = False Then Range("A1").CurrentRegion.AutoFilter
End Sub

Damit spielt es keine Rolle, in welcher Spalte die einzelnen Begriffe stehen - sie müssen nur so geschrieben sein, wie sie im Code stehen. Falls sie anders heißen musst du das nur entsprechend im Code anpassen - ich habe die betreffenden zeilen mit einem Kommentar versehen.

Bis später, Karin

0 Punkte
Beantwortet von
Hallo Karin,

vielen Dank für die super Lösung!!!

es funktioniert bei kleinen Mengen an Daten perfekt.

Jetzt muss ich einmal meine ultra Lange Liste durchjagen, das wird halt schon eine Zeit lange brauchen!

Danke, du hast mir wirklich sehr geholfen.

Ein Lob an das Forum und speziell an solche netten Mitmensche wie du es bist!

lg

Lukas
...