Hoogste waarde uit tabel kopieren naar hoogste waarde uit andere tabel.

Status
Niet open voor verdere reacties.
R

riw

Gebruiker
Lid geworden
30 jan 2017
Berichten
46
Goedemiddag,

In de bijlage zit een bestandje welke ik nu handmatig moet invoeren. Het werkt als volgt;

In kolom D staan waardes. Middels voorwaardelijk opmaak laat ik de cel met daarin de hoogste waarde groen zijn. Tot dat ik in kolom E een waarde invul welke ik uit kolom B haal. In dat geval wordt in kolom D de één na hoogste waarde groen. Waarop ik weer in kolom E een waarde invul. Dit herhaald zich totdat kolom E vol is.

Is het mogelijk om bovenstaande middels een knop te automatiseren? Het is de bedoeling dat steeds de hoogste waarde uit kolom B wordt gekopieerd naar de cel naast de hoogste waarde uit kolom D. Als eenmaal de hoogste waarde uit een cel in kolom B is gekopieerd dan doet die cel in kolom niet meer mee.

Ik hoop dat ik het helder verwoord heb.

Groet,
Rick
 

Bijlagen

  • Waarde toekennen.xlsx
    9,6 KB · Weergaven: 25
Misschien met deze macro onder een knopje:
Code: 
Sub knopje()
Dim rng As Range, cell As Range, i As Long, HighestValue As Long
HighestValue = 0
Set rng = Range("B2:B11")

For Each cell In rng
    If cell.Offset(, 3) = "" Then
        If cell.Value > HighestValue Then HighestValue = cell.Value
    End If
Next cell

For Each cell In rng
    If cell.Offset(, 3) = "" Then
        If cell.Value = HighestValue Then
            cell.Offset(, 3).Value = HighestValue
            Exit For
        End If
    End If
Next cell

End Sub
 
Code: 
Sub BS()
     ThisWorkbook.Names.Add "Kol_B", Range("B2:B11")
     b = [transpose(kol_b)]                                     'b-kolom
     e = [transpose(offset(kol_b,,3,,))]                        'E-kolom
     For j = 1 To UBound(e)                                     'loopje door E-kolom
          If Len(e(j)) > 0 Then                                 'iets ingevuld
               r = Application.Match(e(j), b, 0)                'zoeken in B-kolom
               If IsNumeric(r) Then b(r) = 0                    'indien gevonden, vervangen door een 0
          End If
     Next
     mymax1 = Application.Max(b)                                'max in B-kolom
     r1 = Application.Match(mymax1, b, 0)                       'rijnummer
     d = [transpose(if(offset(kol_b,,3,,)="",offset(kol_b,,2,,),0))]     'getallen in D met niets in E
     mymax2 = Application.Max(d)                                'max van die D's
     r2 = Application.Match(mymax2, d, 0)                       'rijnummer
     With Range("kol_B")                                        'vanuit B-kolom
          .Cells(r2, 4).Value = .Cells(r1, 1).Value             'maxB naar E schrijven
     End With
End Sub
 
Zonder loop:)

Code: 
Sub jec()
 Static i
 Range("B2:E11").Name = "ar"

 If [counta(index(ar,,4))] = [counta(index(ar,,1))] Then i = 0: Exit Sub
 x = [if(index(ar,,4)="",index(ar,,3),"")]
 y = Application.Match(Application.Max(x), x, 0)
 Cells(y + 1, 5) = Evaluate("large(index(ar, , 1)," & i + 1 & ")")
 i = i + 1
End Sub
 
Laatst bewerkt:
Goedenavond. Bedankt voor alle terugkoppelingen, al jullie moeite en tijd. Ik ga er mee aan de slag.
 
Alle drie de opties heb ik toegepast en werken ook. Ik had nog niet eerder gehoord van transpose/transponeren. Als ik voorbeelden zie op internet dan worden hele kolommen met 1 druk op de knop omgezet naar andere cellen. In het huidige bestand dien ik net zo vaak op de knop te drukken tot dat de gehele kolom E gevuld is. Is het ook mogelijk om dit met 1 druk op de knop te realiseren? In bericht #4 staat "nu zonder loop". Betekend dit dat bij de opties uit #2 en #3 het automatisch (loopen) zou moeten gaan?
 

Bijlagen

  • Waarde toekennen (1).xlsm
    23 KB · Weergaven: 23
Voor mijn bijdrage in #2 volstaat deze aanpassing:
Code: 
Sub knopje()
Dim rng As Range, cell As Range, i As Long, HighestValue As Long
Set rng = Range("B2:B11")
For i = 1 To rng.Cells.Count
    HighestValue = -30
    For Each cell In rng
        If cell.Offset(, 3) = "" Then
            If cell.Value > HighestValue Then HighestValue = cell.Value
        End If
    Next cell
    
    For Each cell In rng
        If cell.Offset(, 3) = "" Then
            If cell.Value = HighestValue Then
                cell.Offset(, 3).Value = HighestValue
                Exit For
            End If
        End If
    Next cell
Next i
End Sub
 
Bedankt Gijsbert voor je terugkoppeling. Het lijkt er op als of kolom B nu simpelweg gekopieerd wordt naar kolom E. In jouw eerder code werd de hoogste waarde uit kolom B toegekend aan de hoogste waarde uit kolom E. Dit gebeurd nu niet meer. In het voorbeeld bestand heb ik de code toegekend aan Knop 4.
 

Bijlagen

  • Waarde toekennen (1).xlsm
    24,9 KB · Weergaven: 17
zonder naar het resultaat te kijken, het was gewoon de bedoeling om een loopje te maken tot alles ingevuld is. Dus niet gecheckt.
Maar voor JC loopt die vast, dus ergens een foutje.
 

Bijlagen

  • Waarde toekennen (1).xlsm
    29,2 KB · Weergaven: 22
cow18 zei:
zonder naar het resultaat te kijken, het was gewoon de bedoeling om een loopje te maken tot alles ingevuld is. Dus niet gecheckt.
Maar voor JC loopt die vast, dus ergens een foutje.
Klik om te vergroten...

Ik begrijp niet wat je bedoeld. Wie heeft niet naar het resultaat gekeken en wat is niet gechecked? En wat bedoel je met JC?

In de bijlage die je hebt toegevoegd is de code uit module 2 verplaatst naar module 3. Dat kan toch niet onder 1 knop?
 
ik had in de rapte 2 macros, een BS_Loop en een JC_loop, toegevoegd maar verder niet getest en niet onder die knop gestopt.
 
In eerste instantie leek de loop niet te werken. In tweede instantie heb ik de loop aan een knop toegevoegd en werkte de BS loop. Helemaal top. Bij de jec krijg ik nog een foutmelding.

In de situatie waar het bestand toegepast gaat worden komt nog één variabele voor. Als je me daar nog mee kan helpen dan is het helemaal naar wens.


Ik heb twee kolommen in het bestand bijgevoegd. In de nieuwe situatie mogen Jan en Kees wel elkaars waardes gebruiken. Klaas mag alleen zijn eigen waardes gebruiken.
 

Bijlagen

  • Waarde toekennen (1) (3).xlsm
    23,8 KB · Weergaven: 18
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan