regel op basis van selectie met checkboxen kopiëren

[Excellerend]

Beste medeforumleden,

Voor de VBA-helden onder ons een vraag.
Voorbeeldbestand zoals bijgevoegd is een fictieve situatie, maar wel in essentie vergelijkbaar met mijn bestand.

Ik heb een Excel-bestand die door een aantal personen wordt gebruikt, in dit voorbeeld verkopers.
Zij verkopen producten uit een assortiment, dit assortiment staat op het tabblad "SELECTIE".

Iedere week moet, aan het einde van de week, het verkoopresultaat worden verzameld.
In de werkelijke situatie bestaat het assortiment uit +/- 100 producten i.p.v. 5 zoals in het voorbeeldbestand dus ik wil dat de verkopers de verkochte producten (vooraf) kunnen selecteren.
Op basis van hun selectie moet van de betreffende rij de kolommen A t/m D worden gekopieerd en geplakt onder de laatste regel op het tabblad "GEGEVENS".
(Tabblad "GEGEVENS" en "SELECTIE" zijn van kolom A t/m D identiek)

Een aantal pogingen gewaagd, maar zonder het gewenste resultaat:

Sub Invoegen()

Dim j As Integer

    For j = 1 To 6
        On Error Resume Next
        If ActiveSheet.Shapes("Check Box " & j).ControlFormat.Value = 1 Then
        ActiveShapes.Column("A:D").Copy
        Sheets("GEGEVENS").Activate
        Range("A2").Select
        Selection.End(xlUp).Select
        Selection.Insert Shift:=xlDown
        Application.CutCopyMode = False
    End If
    Next j

End Sub

Ik hoop (verwacht) dat jullie verder komen.

Alvast bedankt!

Grt. Peter

BIJLAGE: Bekijk bijlage Selectie_invoegen.xlsm

 

[snb]

Begin met code wieden: vermijd select en activate in VBA.

 

[Excellerend]

Aangezien de hele code al mis gaat bij regel 4 heb ik nog niet veel verder gekeken.
Ik kom niet verder dan het onderstaande, ik verwacht van je niet direct een oplossing, een goeie hint is zeker zo leerzaam..

Sub Invoegen()

Dim j As Integer

    For j = 1 To 6
        On Error Resume Next
        If ActiveSheet.Shapes("Check Box " & j).ControlFormat.Value = 1 Then
        ActiveShapes.Column("A:D").Copy
        Application.Goto (ActiveWorkbook.Sheets("GEGEVENS").Range("A2").End(xlDown))
        Selection.Offset(1, 0).Insert Shift:=xlDown
        Application.CutCopyMode = False
    End If
    Next j

End Sub

 

[edmoor]

Zoals snb een hekel heeft aan select en activate heb ik een hekel aan On Error Resume Next. Je zegt dan eigenlijk dat het programma zich er niks van aan moet trekken als er wat fout gaat en gewoon door moet gaan en zie je het dus niet als er iets mis is. Ik zeg niet dat het de oorzaak van je probleem is, maar als je die er eerst eens even uit haalt weet je het zeker.

 

[Excellerend]

Beste Edmoor,

In mijn uiteindelijke bestand staat ca. 100 checkboxen, beginnend bij nummer 3, eindigend bij nummer 190. Een tussenliggend aantal (ca. 90 stuks) zijn gesneuveld door het aanpassen / verwijderen van diverse regels.
Helaas nummert Excel door t.o.v. de laatste checkbox.

Wat er dus gebeurd als ik de regel "On Error Resume Next" niet opneem is dat bij de eerst niet bestaande CheckBox Excel de foutmelding "Fout tijdens uitvoering. Het item met de opgegeven naam is niet gevonden" geeft.

De regel is mijns inziens dus noodzaak, al sta ik uiteraard open voor andere oplossingen.

Grt. Peter

 

[edmoor]

Wat ik zelf doe is bij een error een routine aanroepen die controleerd om welke fout het gaat en aan de hand daarvan te beslissen of er kan worden door gegaan of dat er een foutmelding moet worden getoond. Maar dat is in dit geval inderdaad wellicht wat overdone.

 

[pasan]

Als ik mag probeer deze eens

Sub Invoegen()
Dim j As Integer
 With Sheets("SELECTIE")
    For j = 2 To .Shapes.Count
      If .Cells(j, 6).Text = "WAAR" And .Cells(j, 4).Value > 0 Then
        Sheets("GEGEVENS").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(, 4).Value = .Cells(j, 1).Resize(, 4).Value
      End If
    Next j
 End With
End Sub

 

[Excellerend]

Beste Pasan,

Dat is een prima poging

Al moest de code wel een klein beetje aangepast worden, namelijk:

Sub Invoegen()

Dim j As Integer
 With Sheets("SELECTIE")
    For j = 2 To .Shapes.Count
      If .Cells(j, 6).Text = "WAAR" [COLOR="#B22222"]Or[/COLOR] .Cells(j, [COLOR="#B22222"]6[/COLOR]).Value > [COLOR="#B22222"]0.1[/COLOR] Then
        Sheets("GEGEVENS").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(, 4).Value = .Cells(j, 1).Resize(, 4).Value
      End If
    Next j
 End With

End Sub

Kolom F (tabblad "SELECTIE") staat daar bewust, al je namelijk 100 producten moet aanvinken dan is het sneller als je in kolom F een 1 of een 0 kan typen.

Volgens mij gaat dat met de bovenstaande code helemaal goed, waarvoor mijn dank!

Grt. Peter

 

[Excellerend]

Aanvullende op het voorgaande een vraag / verzoek.

Nu worden de geselecteerde cellen overgenomen (Resize) en niet gekopieerd, is het ook mogelijk de geselecteerde cellen te kopiëren / plakken (Insert)?

(Dit omdat er in mijn uiteindelijke sheet ook nog data onderstaat, data die deze code anders gaat overschrijven.)

Grt. Peter

 

[pasan]

Blijf dan toch met de vraag zitten waarom je dan checkboxen wil gebruiken als je, zoals je zelf aangeeft beter (sneller) een 1 of een 0 kunt invullen

Pas zelf aan naar je eigen logica

Sub Invoegen()
Dim j As Integer, R As Long

 With Sheets("SELECTIE")
    For j = 2 To .Shapes.Count
     R = Sheets("GEGEVENS").Cells(2, 1).End(xlDown).Row + 1
      If .Cells(j, 6).Text = "WAAR" And .Cells(j, 4).Value > 0 Then
        Sheets("GEGEVENS").Cells(R, 1).Resize(, 4).Insert Shift:=xlDown
        Sheets("GEGEVENS").Cells(R, 1).Resize(, 4).Value = .Cells(j, 1).Resize(, 4).Value
      End If
    Next j
 End With
End Sub

 

[Excellerend]

Ik heb er dit van gemaakt:

Sub Invoegen()
Dim j As Integer, R As Long

 With Sheets("SELECTIE")
    For j = 2 To .Shapes.Count
     R = Sheets("GEGEVENS").Cells(2, 1).End(xlDown).Row + 1
      If .Cells(j, 6).Text = "WAAR" [COLOR="#B22222"]Or[/COLOR] .Cells(j, [COLOR="#B22222"]6[/COLOR]).Value > [COLOR="#B22222"]0.1[/COLOR] Then
        Sheets("GEGEVENS").Cells(R, 1)[COLOR="#B22222"].EntireRow[/COLOR].Insert Shift:=xlDown
        Sheets("GEGEVENS").Cells(R, 1).Resize(, 4).Value = .Cells(j, 1).Resize(, 4).Value
      End If
    Next j
 End With
End Sub

Dat werkt vooralsnog goed. Nogmaals bedankt!

Grt. Peter

 

[snb]

In mijn uiteindelijke bestand staat ca. 100 checkboxen, beginnend bij nummer 3, eindigend bij nummer 190. Een tussenliggend aantal (ca. 90 stuks) zijn gesneuveld door het aanpassen / verwijderen van diverse regels.
Helaas nummert Excel door t.o.v. de laatste checkbox.

Omdat jij zelf geen naam aan de vinkvakken geeft doet Excel dat voor jou.
Jij kunt ten alle tijde de namen van vinkvakken wijzigen, zodat ze wel 'op elkaar aansluiten'.

Sub M_snb()
    For j = 1 To Blad2.CheckBoxes.Count
       Blad2.CheckBoxes(j).Name = j & "_vink"
    Next
    
End Sub


Sub M_snb_002()
    For Each vk In Blad2.CheckBoxes
      If vk.Value = 1 Then Blad1.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 3) = Blad2.Cells(Val(vk.Name) + 1, 1).Resize(, 3).Value
    Next
End Sub

 

[Excellerend]

Toppie, ik heb nu checkbox "Dankzijsnb_1" tot "Dankzijsnb_91"!

Je kan het ook eens zijn met de gebruikte code? #durftevragen