Material und Arbeitsplatz

Guten Tag,
ich habe seit geraumer Zeit ein Problem dass ich verzweifelt versuche zu lösen.
Nun bin ich an einen Punkt angelangt, wo ich eure Hilfe bräuchte.
Ich habe eine Liste in der Produkte in Spalte A aufgeführt sind.
In Spalte C bis Y sind die Plätze hinterlegt in der das Produkt gefertigt wird.
Die Zahl in Spalte C bis y gibt die Reihenfolge an.
https://www.herber.de/bbs/user/122048.xlsx
Ich bräuchte nun ein Macro das so in der Art laufen sollte:
Schleife für Spalte A Produkte
- Schreibe erstes Produkt in Tabelle Ergebnis.
- Suche in der Zeile nach der kleinsten Zahl und trage dann die Überschrift (Arbeitsplatz in Spalte B)
- Suche nach zweitgrößter Zahl... Überschrift in Spalte C usw.
Keine Zahl mehr dann
Schleife mit nächstem Produkt fortsetzen.
Gibt es jemanden, der mir das in VBA schreiben könnte?
Liebe Gruesse
Stefan

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
so?
in ein normales Modul

Sub Fluss_Index()
    Dim TB1, TB2, LR As Double, LC As Integer, ZE As Integer, SE As Integer, Zeile As Double, Spalte As Integer
    Dim Anz As Integer, Sk As Integer, WE As Integer, Ins As Double, Arr As Range
    
    Set TB1 = Sheets("Tabelle1")
    Set TB2 = Sheets("Ergebnis")
    
    ZE = 2 'Zeile Überschrift 
    SE = 3 'erste Spalte mit Daten 
    
    LR = TB1.Cells(TB1.Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte 
    LC = TB1.Cells(ZE, TB1.Columns.Count).End(xlToLeft).Column 'letzte Spalte einer Zeile 
   
    TB2.Cells.ClearContents 'Reset 
    
    Ins = 1 'Einfügezeile 
    
    With TB1
        For Zeile = ZE + 1 To LR
            Set Arr = .Range(.Cells(Zeile, SE), .Cells(Zeile, LC))
            
            TB2.Cells(Ins, 1) = .Cells(Zeile, 1)
            TB2.Cells(Ins, 2) = .Cells(Zeile, 2)
            
            Anz = WorksheetFunction.CountA(Arr) 'Anzahl Folgen 
            
            For Sk = 1 To Anz
            
                WE = WorksheetFunction.Small(Arr, Sk) 'Kkleinster Wert 
                Spalte = WorksheetFunction.Match(WE, Arr, 0) + SE - 1 'Spalte der Wertes 
                TB2.Cells(Ins, 2).Offset(0, Sk) = .Cells(ZE, Spalte) 'Überschrift der Spalte übertragen 
            
            Next Sk
            
            Ins = Ins + 1 'nächste Einfügespalte 
       Next Zeile
    End With
End Sub

LG UweD

Sub test() Dim Erg, ÜB, Werte, X Dim von As Long, bis As Long Dim z As Long, s As Long With Sheets("Tabelle1").UsedRange Erg = .Offset(2, 0).Resize(.Rows.Count - 2, 3).Value ÜB = .Rows(2).Offset(0, 2).Resize(.Rows.Count - 2).Value Werte = .Offset(2, 2).Resize(.Rows.Count - 2, .Columns.Count - 2).Value End With von = WorksheetFunction.Min(Werte) bis = WorksheetFunction.Max(Werte) For z = 1 To UBound(Erg, 1) ReDim X(von To bis) As String For s = 1 To UBound(Werte, 2) If VarType(Werte(z, s)) = vbDouble Then X(Werte(z, s)) = ÜB(1, s) Next Erg(z, 3) = WorksheetFunction.Trim(Join(X, " ")) Next With Sheets("Ergebnis") .Cells.Clear .Cells(1, 1).Resize(UBound(Erg, 1), UBound(Erg, 2)) = Erg .Columns(3).TextToColumns Destination:=.Range("C1"), DataType:=xlDelimited, _ Tab:=False, Semicolon:=False, Comma:=False, Space:=True, Other:=False End With End Sub

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread