Laagste waarde van tablad 1 overschrijven naar tablad 3

[gast0660]

Beste forumleden,

Hierbij een bestandje

Het is de bedoeling dat de LAAGSTE prijs van tabblad "prijsvergelijking " wordt overgeschreven naar tabblad "overzicht" met meename van categorie,product,merk en gewicht en winkel graag in vba, met formules krijg ik wel iets voor elkaar maar het ziet er niet uit.

alvast bedankt voor het meedenken

mvg

gast0660

 

[mcs51mc]

Toch wel een paar vragen eerst...

1) Met welke knop moet dat gebeuren? Eén van de bestaande of mag het een nieuwe zijn of moet er een andere trigger zijn?
2) Wat met 2 gelijke laagste prijs? Stel het laagste is 3.25 maar die komt er x keren in voor, welke moet er dan gekozen worden?
3) Is het wel zinvol om dat over alle categorien heen te doen? Ik bedoel, je gaat de prijzen van koffie, melk, pralines, worst, fruitsap ... ... ... ... alles door elkaar heen vergelijken? Wat is daar het nut van??


Of heb ik de vraag verkeerd begrepen?
Wil je van elke rij de winkel met de laagste prijs hebben?
Dus de Colruyt voor rij 2 en Delahize voor rij 3?
Finaal heb je dus even veel rijen in sheet "Overzicht" maar met slechts één winkel.
Is dat het??

 

[mcs51mc]

Met deze (in 't lang en in 't breed uitgeschreven) code zou het moeten lukken

Sub CopyMinimumPrijs()
Dim i As Long
Dim dblLowest   As Double
Dim lngCol      As Long

    With ActiveSheet
        i = 1
        
        Do
            'Laagste prijs in huidige rij bepalen alsook welke kolom het is
            dblLowest = CDbl(Application.WorksheetFunction.Min(.Range(.Range("A1").Offset(i, 3), .Range("A1").Offset(i, 8))))
            lngCol = Application.WorksheetFunction.Match(dblLowest, .Range(.Range("A1").Offset(i, 3), .Range("A1").Offset(i, 8)), 0)
            
            'Data huidige rij kopiëren
            .Range(.Range("A1").Offset(i, 0), .Range("A1").Offset(i, 2)).Copy
            Worksheets("Overzicht").Range("A1").Offset(i, 0).PasteSpecial Paste:=xlPasteValues, _
                                                                          Operation:=xlNone, _
                                                                          SkipBlanks:=False, _
                                                                          Transpose:=False
            
            'Winkel kopiëren
            .Range("A1").Offset(0, lngCol + 2).Copy
            Worksheets("Overzicht").Range("A1").Offset(i, 3).PasteSpecial Paste:=xlPasteValues, _
                                                                          Operation:=xlNone, _
                                                                          SkipBlanks:=False, _
                                                                          Transpose:=False
            
            'Prijs kopiëren
            Worksheets("Overzicht").Range("A1").Offset(i, 4).Value = dblLowest

            
            i = i + 1
               
        Loop While Not IsEmpty(.Range("A1").Offset(i, 0))
    End With
End Sub

Véél plezier ermee... ...

 

[HSV]

Hier ook nog twee codes:

Sub hsv()
Dim cl As Range, Rng As Range, sq, sn, minus As Range
With Sheets("prijsvergelijking")
For Each cl In .Columns(1).SpecialCells(2).Offset(1).SpecialCells(2)
    Set Rng = .Range(.Cells(cl.Row, 4), .Cells(cl.Row, 9))
 Set minus = Rng.Find(WorksheetFunction.Min(Rng))
    sq = cl & "|" & cl.Offset(, 1) & "|" & cl.Offset(, 2) & "|" & .Cells(1, minus.Column) & "|" & minus
    sn = Split(sq, "|")
With Sheets("overzicht").Cells(Rows.Count, 1).End(xlUp)
    .Offset(1).Resize(, 4) = sn
    .Offset(1, 4) = CCur(sn(UBound(sn)))
 End With
   Next cl
 End With
End Sub

Of:

Sub hsvtwee()
Dim a, i As Long, j As Long, n As Long, t As Long, Rng As Range, c As Range
With Sheets("prijsvergelijking")
 With .Range("A1").CurrentRegion
    a = .Value
  End With
ReDim b(1 To UBound(a), 1 To 5)
      n = 1
For i = 2 To UBound(a)
For j = 1 To 4
     t = t + 1
   If t > 3 Then
     Set Rng = .Range(.Cells(i, 4), .Cells(i, 9))
    Set c = Rng.Find(WorksheetFunction.Min(Rng))
       b(n, t) = a(1, c.Column)
          t = t + 1
       b(n, t) = a(i, c.Column)
     Else
   b(n, t) = a(i, j)
End If
  If t > 4 Then
      t = 0: n = n + 1
     End If
      Next j
    Next i
 Sheets("overzicht").Range("A2").Resize(n, 5) = b
 End With
End Sub

 

[gast0660]

Beste forumleden;

De codes van jullie beidden werken perfect waarvoor hartelijk dank?
Hiermee is mijn probleem opgelost.

mvg

Philiep