Stückliste abgleichen

Hallo Freunde,
als erstes einmal finde ich das Forum super. Ich habe mir hier bereits so viel Sachen gehollt die mir bei meiner Arbeit helfen. Nun habe ich aber ein Problem welches ich nicht gelöst bekomme.
Problem:
Ich habe eine Liste mit Überschriften (Bold) und dort stehen diverse Artikel drunter. Jetzt muss ich aus einer anderen Liste abgleichen ob dort die Überschrift existiert. Wenn dem so ist soll in der Liste mit den Überschriften 4 Zellen ausgefüllt werden (mit der Anzahl und Artikelnummer aus Liste 2). wenn das geschehen ist müssen 2 leere Zeilen eingefügt werden und dann soll nach der nächsten Überschrift gesucht werden.
Die Listen befinden sich in einer Exceldatei und in verschiedenen Tabellen.
LG und vielen Dank Marc

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Beispieldatei?

13.12.2018 09:37:41

UweD

AW: Beispieldatei?

13.12.2018 09:45:51

marc

Nachfrage..

13.12.2018 09:58:37

UweD

AW: Nachfrage..

13.12.2018 10:12:39

marc

AW: Nachfrage..

13.12.2018 12:08:21

UweD

AW: Nachfrage..

13.12.2018 12:24:11

marc

Danke für die Rückmeldung owT

13.12.2018 12:43:35

UweD

Hallo
so?
Modul1

Option Explicit 
 
Sub Stüli() 
    Dim TB1, TB2, LastZ As Double, i As Double 
    Dim LR As Double, Z1 As Integer, Pos As Integer, Anz As Integer 
    Dim WF, Sp1 As Integer, Sp2 As Integer 
     
    Set TB1 = Sheets("Stückliste") 
    Set TB2 = Sheets("Halfenanbindung") 
    Set WF = WorksheetFunction 
 
    Z1 = 6 ' Erste Zeile mit Daten 
    Sp1 = 2 ' Spalte B 
    Sp2 = 5 ' Spalte E 
     
    LR = TB1.Cells(TB1.Rows.Count, Sp1).End(xlUp).Row 'letzte Zeile der Spalte 
     
    With TB1 
        LastZ = LR 'unterste Zeile des Blockes 
         
        For i = LR To Z1 Step -1 
             
            'Leere Zeilen ignorieren 
            If .Cells(i, Sp1) = "" Then 
                LastZ = LastZ - 1 
            End If 
             
            'Fette Zellen finden 
            If .Cells(i, Sp1) <> "" And .Cells(i, Sp1).Font.Bold Then 
                 
                'in Tabelle2 vorhanden? 
                If WF.CountIf(TB2.Columns(1), .Cells(i, Sp1)) > 0 Then 
                     
                    'Anzahl für Menge auslesen 
                    Anz = TB2.Cells(WF.Match(.Cells(i, Sp1), TB2.Columns(1)), 2) 
                     
                    'Anzahl Positionen (minus Überschrift) 
                    Pos = WF.CountA(TB2.Columns(Sp2)) - 1 
                     
                    'Anzahl Elemente plus 2 Leerzeichen einfügen 
                    .Rows(LastZ + 1).Resize(Pos + 2).Insert 
                     
                    'Positionen einfügen 
                    .Cells(LastZ + 1, Sp1).Resize(Pos, 1).Value = _
                        TB2.Cells(2, Sp2).Resize(Pos, 1).Value 
                     
                    'Anzahl eintragen 
                    .Cells(LastZ + 1, Sp1).Offset(, 1).Resize(Pos, 1) = Anz 
                     
                    'Artnum und Einheit eintragen 
                    .Cells(LastZ + 1, Sp1).Offset(, 2).Resize(Pos, 2).Value = _
                        TB2.Cells(2, Sp2).Offset(, 2).Resize(Pos, 2).Value 
                     
                    'Gewicht eintragen 
                    .Cells(LastZ + 1, Sp1).Offset(, 9).Resize(Pos, 1).Value = _
                        TB2.Cells(2, Sp2).Offset(, 4).Resize(Pos, 1).Value 
                     
                    'Gesamtgewicht errechnen 
                    With .Cells(LastZ + 1, Sp1).Offset(, 10).Resize(Pos, 1) 
                        .FormulaR1C1 = "=RC[-9]*RC[-1]" 
                        .Value = .Value 
                    End With 
                     
                End If 
                LastZ = i - 1 
            End If 
        Next 
    End With 
End Sub

LG UweD

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread