• 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.

Meerdere codes samenvoegen

Status
Niet open voor verdere reacties.
D

dizzeenl

Gebruiker
Lid geworden
20 nov 2011
Berichten
10
Hallo,

Hoe kan ik deze codes het beste samenvoegen? ik heb al wat informatie gevonden over intersect e.d. of Case opties maar kom er niet echt uit. De oplossing met Range en Range2 is ook niet helemaal zoals het hoort maar heb ik wel werkend gekregen. Hoe kan ik deze set samen werkend krijgen?

Code: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, cancel As Boolean)
Dim cel As Range, targ As Range
If Target.Cells.Count > 1 Then Exit Sub

Set targ = Range("Kamers")   'Watch these cells for user selections
Set targ = Intersect(targ, Target)
If targ Is Nothing Then Exit Sub
ActionForm.Show
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim myrange As Range
    Set myrange = Range("VenU")
     
    If Not Intersect(myrange, Target) Is Nothing Then
        If ActiveCell.Value = "" Then
            ActiveCell.Value = "a"
            ActiveCell.Offset(0, 1).Select
Else:
            ActiveCell.ClearContents
            ActiveCell.Offset(0, 1).Select
        End If
    End If
    Dim myrange2 As Range
    Set myrange2 = Range("OpDat")
     
    If Not Intersect(myrange2, Target) Is Nothing Then
        If ActiveCell.Value = "" Then
            ActiveCell.Value = Date
            
        End If
    End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
' Developed by Contextures Inc.
' www.contextures.com
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim lUsed As Long
If Target.Count > 1 Then GoTo exitHandler

On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler

If rngDV Is Nothing Then GoTo exitHandler

If Intersect(Target, rngDV) Is Nothing Then
Else
  Application.EnableEvents = False
  newVal = Target.Value
  Application.Undo
  oldVal = Target.Value
  Target.Value = newVal
  If Target.Column = 24 Then
    If oldVal = "" Then
      Else
      If newVal = "" Then
      Else
        lUsed = InStr(1, oldVal, newVal)
        If lUsed > 0 Then
            If Right(oldVal, Len(newVal)) = newVal Then
                Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 2)
            Else
                Target.Value = Replace(oldVal, newVal & ", ", "")
            End If
        Else
            Target.Value = oldVal _
              & ", " & newVal
        End If
        
      End If
    End If
  End If
End If

exitHandler:
  Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
' Developed by Contextures Inc.
' www.contextures.com
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim lUsed As Long
If Target.Count > 1 Then GoTo exitHandler

On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler

If rngDV Is Nothing Then GoTo exitHandler

If Intersect(Target, rngDV) Is Nothing Then
Else
  Application.EnableEvents = False
  newVal = Target.Value
  Application.Undo
  oldVal = Target.Value
  Target.Value = newVal
  If Target.Column = 25 Then
    If oldVal = "" Then
      Else
      If newVal = "" Then
      Else
        lUsed = InStr(1, oldVal, newVal)
        If lUsed > 0 Then
            If Right(oldVal, Len(newVal)) = newVal Then
                Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 2)
            Else
                Target.Value = Replace(oldVal, newVal & ", ", "")
            End If
        Else
            Target.Value = oldVal _
              & ", " & newVal
        End If
        
      End If
    End If
  End If
End If

exitHandler:
  Application.EnableEvents = True
End Sub
 
Welke van de vier wil je samenvoegen? Zo misschien?

Code: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, cancel As Boolean)
  If Not Intersect(Target, Range("Kamers")) Is Nothing Then Actionform.Show
End Sub
Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Intersect(Target, Union(Range("VenU"), Range("OpDat"))) Is Nothing Then Exit Sub
  Select Case Target.Column
    Case Range("VenU").Column
      Target.Value = IIf(Target.Value = "", "a", "")
      Target.Offset(, 1).Select
    Case Range("OpDat").Column
      Target.Value = IIf(Target.Value = "", Date, Target.Value)
  End Select
End Sub
Bovenstaande werkt alleen als de gedefinieerde namen uit 1 kolom bestaan

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim r As Range, oud As String, nieuw As String
  On Error Resume Next
  Set r = Columns(24).Resize(, 2).SpecialCells(xlCellTypeAllValidation)
  If r Is Nothing Then Exit Sub
  If Intersect(Target, r) Is Nothing Or Target.Count > 1 Then Exit Sub
  
  With Application
    .EnableEvents = False
    nieuw = Target.Value
    .Undo
    oud = Target.Value
    Target.Value = nieuw
    If oud <> "" And nieuw <> "" Then
      If InStr(1, oud, nieuw) > 0 Then
        If Right(oud, Len(nieuw)) = nieuw Then
          Target.Value = Left(oud, Len(oud) - Len(nieuw) - 2)
        Else
          Target.Value = Replace(oud, nieuw & ", ", "")
        End If
      Else
        Target.Value = oud & ", " & nieuw
      End If
    End If
    .EnableEvents = True
  End With
End Sub
 
Het gaat eigenlijk om de laatste 3 codes.

De eerste code zorgt ervoor dat als de gebruiker op een kamernummer (cel) klikt er een menu geopend wordt (actionform). Dit werkt prima.

HTML: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, cancel As Boolean)
Dim cel As Range, targ As Range
If Target.Cells.Count > 1 Then Exit Sub

Set targ = Range("Kamers")   'Watch these cells for user selections
Set targ = Intersect(targ, Target)
If targ Is Nothing Then Exit Sub
ActionForm.Show
End Sub

de tweede code zorgt in het geval bij de range VenU kolom dat er een vinkje in de cel komt wanneer er op geklikt wordt. En in geval bij range2 de huidige datum in de Opdat kolom. ik heb hiervoor de range gekopieerd en hernoemt. Werkt prima maar lijkt een wat omslachtige oplossing.
De code van VenA is hierbij het betere alternatief. Ik ga de werking doorspitten, bedankt

De laatste twee codes moeten en bepaalde kolommen met een lijst validatie deze code gebruiken om meerdere opties te kunnen selecteren uit de lijst (dropdown) en wanneer dezelfde waarde nogmaals wordt geselecteerd moet de waarde weer uit de opsomming worden verwijderd. Een enkele kolom krijg ik werkend maar wil dus eigenlijk de code voor meerdere kolommen werkend kunnen maken. Hetzij door het opgeven van namen van bereiken zoals hierboven of door columnummer (24 en 25 in dit geval)

HTML: 
Private Sub Worksheet_Change(ByVal Target As Range)
' Developed by Contextures Inc.
' www.contextures.com
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim lUsed As Long
If Target.Count > 1 Then GoTo exitHandler

On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler

If rngDV Is Nothing Then GoTo exitHandler

If Intersect(Target, rngDV) Is Nothing Then
Else
  Application.EnableEvents = False
  newVal = Target.Value
  Application.Undo
  oldVal = Target.Value
  Target.Value = newVal
  If Target.Column = 24 Then
    If oldVal = "" Then
      Else
      If newVal = "" Then
      Else
        lUsed = InStr(1, oldVal, newVal)
        If lUsed > 0 Then
            If Right(oldVal, Len(newVal)) = newVal Then
                Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 2)
            Else
                Target.Value = Replace(oldVal, newVal & ", ", "")
            End If
        Else
            Target.Value = oldVal _
              & ", " & newVal
        End If
        
      End If
    End If
  End If
End If

exitHandler:
  Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
' Developed by Contextures Inc.
' www.contextures.com
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim lUsed As Long
If Target.Count > 1 Then GoTo exitHandler

On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler

If rngDV Is Nothing Then GoTo exitHandler

If Intersect(Target, rngDV) Is Nothing Then
Else
  Application.EnableEvents = False
  newVal = Target.Value
  Application.Undo
  oldVal = Target.Value
  Target.Value = newVal
  If Target.Column = 25 Then
    If oldVal = "" Then
      Else
      If newVal = "" Then
      Else
        lUsed = InStr(1, oldVal, newVal)
        If lUsed > 0 Then
            If Right(oldVal, Len(newVal)) = newVal Then
                Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 2)
            Else
                Target.Value = Replace(oldVal, newVal & ", ", "")
            End If
        Else
            Target.Value = oldVal _
              & ", " & newVal
        End If
        
      End If
    End If
  End If
End If

exitHandler:
  Application.EnableEvents = True
End Sub
 
Laatst bewerkt:
Ook de laatste werkt in mijn code volgens mij. Plaats het bestand even dan wordt het misschien wat duidelijker.
 
Hoi VenA,

Het laatste werkt inderdaad ook prima. Het bestand staat nog vol vertrouwelijke informatie dus vandaar op deze manier.

Ik ben nog aan het achterhalen hoe ik meerdere kolommen kan toevoegen aangezien in jouw voorbeeld alleen kolom 24 staat geselecteerd?
HTML: 
Set r = Columns(24).Resize(, 2).SpecialCells(xlCellTypeAllValidation)

Een range in de vorm van "W:Z" werkt ook maar die liggen naast elkaar.
kan ik hier zo zelfde iets toevoegen als bovenstaand?

Code: 
Intersect(Target, Union(Range("VenU"), Range("OpDat")))

Het plaatsen van meerdere colomgetallen lijkt in ieder geval niet te werken
HTML: 
Set r = Columns(24,25).Resize(, 2).SpecialCells(xlCellTypeAllValidation)
 
Van elk bestand is zeer eenvoudig een voorbeeldbestand te maken.
In mijn code zijn de kolommen 24 en 25 'geselecteerd' Dus niet alleen kolom 24. Als je afzonderlijke kolommen wilt gebruiken kan je daar inderdaad een Union voor gebruiken.

bv
Code: 
Union(Range("W:W"),Range("Z:Z"))
 
Laatst bewerkt:
De code blijkt alleen niet te werken als de sheet beveiligd is (Oops :shocked:)
Dat heeft te maken met Cells.SpecialCells(xlCellTypeAllValidation) ?
 

Bijlagen

  • vraag2.xlsx
    9,1 KB · Weergaven: 32
Laatst bewerkt:
Maak er een voorbeeldbestand van die betrekking heeft op de vraag.
 
Er zit geen code in een .xlsx dus even beter je best doen.
 
sorry mijn fout.

Opslaan als Xlsm werkt beter :)

Enfin. de code is aangepast zodat hij werkt in de H en J. Echter wanneer de sheet beveiligd is, wordt de code niet opgepakt

De eerste code werkte in het voorbeeld bestand inderdaad over 2 kolommen door de .Resize(, 2) toevoeging.
Echter in het eigen bestand, waarin meerdere codes zijn verwerkt gaf dit problemen in de zin dat alleen de eerst gegeven kolom werkt.

Met de Union range werkt het in ieder geval prima. en Resteert alleen het probleem met de beveiligde sheet, die de werking blokkeert door het niet kunnen toepassen van
.SpecialCells(xlCellTypeAllValidation) ?
 

Bijlagen

  • vraag2b.xlsm
    16 KB · Weergaven: 35
Laatst bewerkt:
Volgens mij kan het niet; een soort kip en ei verhaal. Je mag niets wijzigen door de beveiliging en pas nadat je wat gewijzigd hebt kan de beveiliging eraf gehaald worden. Dit kan je wel weer oplossen met Worksheet_SelectionChange maar dan kom je mogelijk weer in de knoei met jouw andere Worksheet_SelectionChange.

Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Column = 10 Then ActiveSheet.Unprotect
End Sub

En dan ergens in de Worksheet_Change procedure de beveiliging weer aanzetten
 
Het verwijderen van .SpecialCells(xlCellTypeAllValidation) in de code maakt het geheel in ieder geval werkend op een beveiligde sheet.
Aangezien de range gespecificeerd is in de opgegeven kolommen zal het niet veel uitmaken, lijkt mij
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan