• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

vba code inkorten

Status
Niet open voor verdere reacties.
B

bowlingman

Gebruiker
Lid geworden
17 okt 2007
Berichten
433
Ik heb een file waarin,als cel B3 wijzigt, automatisch een aantal rijen naar beneden wordt gescrold.
Kan je de volgende code ook korter schrijven
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Range("B3").Value = "1" Then
        ActiveWindow.ScrollRow = 4
    End If
    If Range("B3").Value = "2" Then
        ActiveWindow.ScrollRow = 19
    End If
    If Range("B3").Value = "3" Then
        ActiveWindow.ScrollRow = 34
    End If
    If Range("B3").Value = "4" Then
        ActiveWindow.ScrollRow = 49
    End If
    If Range("B3").Value = "5" Then
        ActiveWindow.ScrollRow = 64
    End If
    If Range("B3").Value = "6" Then
        ActiveWindow.ScrollRow = 79
    End If
    If Range("B3").Value = "7" Then
        ActiveWindow.ScrollRow = 94
    End If
    If Range("B3").Value = "8" Then
        ActiveWindow.ScrollRow = 109
    End If
    If Range("B3").Value = "9" Then
        ActiveWindow.ScrollRow = 124
    End If
    If Range("B3").Value = "10" Then
        ActiveWindow.ScrollRow = 139
    End If
    If Range("B3").Value = "11" Then
        ActiveWindow.ScrollRow = 154
    End If
    If Range("B3").Value = "12" Then
        ActiveWindow.ScrollRow = 169
    End If
    If Range("B3").Value = "13" Then
        ActiveWindow.ScrollRow = 184
    End If
    If Range("B3").Value = "14" Then
        ActiveWindow.ScrollRow = 199
    End If
    If Range("B3").Value = "15" Then
        ActiveWindow.ScrollRow = 214
    End If
    If Range("B3").Value = "16" Then
        ActiveWindow.ScrollRow = 229
    End If
    If Range("B3").Value = "17" Then
        ActiveWindow.ScrollRow = 244
    End If
    If Range("B3").Value = "18" Then
        ActiveWindow.ScrollRow = 259
    End If
    If Range("B3").Value = "19" Then
        ActiveWindow.ScrollRow = 274
    End If
    If Range("B3").Value = "20" Then
        ActiveWindow.ScrollRow = 289
    End If
    If Range("B3").Value = "21" Then
        ActiveWindow.ScrollRow = 304
    End If
    If Range("B3").Value = "22" Then
        ActiveWindow.ScrollRow = 319
    End If
    If Range("B3").Value = "23" Then
        ActiveWindow.ScrollRow = 334
    End If
    If Range("B3").Value = "24" Then
        ActiveWindow.ScrollRow = 349
    End If
    If Range("B3").Value = "25" Then
        ActiveWindow.ScrollRow = 364
    End If
    If Range("B3").Value = "26" Then
        ActiveWindow.ScrollRow = 379
    End If
End Sub
 
het is bijna:

4+(value-1)*15 ?

lijkt me de makkelijkste benadering
 
Volgens mij moet je in deze richting zoeken.
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  If Intersect(Target, Range("B3")) Is Nothing Or Target.Count <> 1 Then Exit Sub
  Application.Goto Cells(Target.Value * 15 - 11, 1)
End Sub
 
zou de scroll= true nog even toevoegen:
plus nog wat veiligheidjes:

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  If Intersect(Target, Range("B3")) Is Nothing Or Target.Count <> 1 Or Not IsNumeric(Target.Value) Then Exit Sub
  If Target.Value > 0 Then Application.Goto Cells(Int(Target.Value) * 15 - 11, 1), True
End Sub
 
Maar begrijp je de suggesties ook ?
 
Hallo Snb,
Ik dacht dat de regel "If Intersect" er voor zorgt dat de Worksheet_change enkel maar gebeurt als cel B3 wijzigt, wanneer er in eerder welke andere cel iets wijzigt moet de sub verlaten worden en dus niets gedaan worden.
De Application GoTo vermenigvuldigd eigenlijk de in B3 ingegeven waarde en trekt daar in dit geval 11 af omdat het scrollen pas gebeurd vanaf rij 4 en de 1 achter de komma staat voor de exacte overeenkomst.
Zo scrolt er dus bij bv 5 in B3 5*15 = 75 - 11 is 64 rijen.
Althans dat dacht ik zo

Grtjs.
Armand
 
Bijna goed. Wijzig de 1 achter de komma eens in bv 5 en zie waar je uitkomt.
 
Hallo VenA

Ik heb het eens gedaan zoals jij voorstelt en dan gebeurt er niets.
Waar staat dan die 1 na de komma voor

Grtjs.
Armand
 
Waarschijnlijk de verkeerde 1 gewijzigd in een 5; dan gebeurt er ook niets.
De 1 achter de komma moet je wijzigen.
 
Hallo Helpers,
Na aanpassingen van mijn sheet, had ik ook al de code aangepast
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  If Intersect(Target, Range("C1")) Is Nothing Or Target.Count <> 1 Or Not IsNumeric(Target.Value) Then Exit Sub
  If Target.Value > 0 Then Application.Goto Cells(Int(Target.Value) * 36 - 32, 1), True
  Range("C1").Select
End Sub
Door de "Range.select" gebeurde er niets.
Na deze regel te deactiveren en de 1 na de komma te wijzigen scrolde alles zowel naar beneden als naar links.
Dus de 1 na de komma zorgt er dan voor dat kolom A op mijn scherm de eerste kolom blijft en met 5 wordt dat kolom E.
Juist?

Grtjs.
Armand
 
Laatst bewerkt:
Ik heb op het form een derde OptionButton toegevoegd en de volgende code bijgevoegd
Code: 
Private Sub Opt3_Click()
  Label5.Caption = "Kampioenschappen"
  With ComboBox1
    .Clear
    If Opt3 = True Then .List = Array("Kampioenschappen1", "Kampioenschappen2", "Kampioenschappen3", "Kampioenschappen4", "Kampioenschappen5", "Kampioenschappen6", "Kampioenschappen7", "Kampioenschappen8", "Kampioenschappen9", "Kampioenschappen10")
  End With
End Sub
Voor het wegschrijven heb ik de code aangepast
Code: 
Private Sub cmbWegschrijven_Click()
Application.ScreenUpdating = False
 Sheets("Scores").Range("B4:B39").Offset(ComboBox1.ListIndex * 35 + IIf(Opt1, 0, 792)[COLOR="#FF0000"].Offset(ComboBox1.ListIndex * 35 + IIf(Opt2, 0, 936)[/COLOR])).Find(cboNaam.Value).Offset(, IIf(LCase(TextBox2.Text = "uit"), 7, 1)).Resize(, 6) = Array(txtG1.Value, txtG2.Value, txtG3.Value, txtG4.Value, txtG5.Value, txtG6.Value)
cboNaam.Value = ""
Application.ScreenUpdating = True
End Sub
Maar dan krijg ik een foutmelding
Als ik de code zo aanpas
Code: 
Private Sub cmbWegschrijven_Click()
Application.ScreenUpdating = False
 Sheets("Scores").Range("B4:B39").Offset(ComboBox1.ListIndex * 35 + IIf(Opt1, 0, 792[COLOR="#FF0000"],Opt2, 0, 936[/COLOR])).Find(cboNaam.Value).Offset(, IIf(LCase(TextBox2.Text = "uit"), 7, 1)).Resize(, 6) = Array(txtG1.Value, txtG2.Value, txtG3.Value, txtG4.Value, txtG5.Value, txtG6.Value)
cboNaam.Value = ""
Application.ScreenUpdating = True
End Sub
Krijg ik ook een foutmelding
De originele code staat in de file

Grtjs.
Armand
 

Bijlagen

Deze code had ik je ergens in een ander vraag gegeven; overigens graag gedaan nog.

Code: 
Private Sub cmbWegschrijven_Click()
 Sheets("Scores").Range("B4:B39").Offset(ComboBox1.ListIndex * 35 + IIf(Opt1, 0, 792)).Find(cboNaam.Value).Offset(, IIf(LCase(TextBox2.Text = "uit"), 7, 1)).Resize(, 6) = Array(txtG1.Value, txtG2.Value, txtG3.Value, txtG4.Value, txtG5.Value, txtG6.Value)
cboNaam.Value = ""
End Sub

Waar staat het bereik voor opt3 → de kampioenschappen?
 
Hallo HSV
Sorry dat ik U hiervoor niet bedankt had.
Het is die code van U die ik wou aanpassen met een derde OptionButton.
Wanneer deze wordt geselecteerd (Opt3) moeten de codes weggeschreven worden in de rijen 940 en hoger.

Grtjs.
Armand
 
Je zou hem hier kunnen plaatsen
Code: 
Private Sub cmbWegschrijven_Click()
Application.ScreenUpdating = False
 Sheets("Scores").Range("B4:B39").Offset(ComboBox1.ListIndex * 35 + IIf(Opt1, 0, [COLOR=#0000FF]IIf(Opt2, 792, 940)))[/COLOR].Find(cboNaam.Value).Offset(, IIf(LCase(TextBox2.Text = "uit"), 7, 1)).Resize(, 6) = Array(txtG1.Value, txtG2.Value, txtG3.Value, txtG4.Value, txtG5.Value, txtG6.Value)
 cboNaam.Value = ""
Application.ScreenUpdating = True
End Sub
 
Trek er 36 af: = 904
 
Jack, HSV

Bedankt voor jullie hulp.
Alles werkt nu zoals ik bedoelde en ga dit verder uitwerken tot een volledig progje.

Grtjs.
Armand
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan