data wegschrijven naar een extern blad in een specifiek veld plaatsen

rogersmeets · 30 dec 2023

nooit een cursus gehad ik probeer het door te doen en te vragen te leren, ik weet deze nu.

rogersmeets · 30 dec 2023

Nu jou code in button 2 en 3 verwerken:

button 3: gaat fout

Code:

Sub Button3_Click()

Set sh = Sheets("Teamleider-Productie Dashboard")
If IsDate(sh.Range("E45")) Then

    With Sheets("Jaarproductie Karren " & Year(sh.Range("E45")))
          r = Application.Match(sh.Range("e45"), .Columns(2), 0)
          If IsNumeric(r) Then
                 .Cells(r, 3).Resize(, 7).Value = sh.Range("f37:l37").Value
                 .Cells(r, 11) = sh.Range("N40").Value
     
                 For Each cl In .Cells(r, 3).Resize(, 7)
                   cl.Interior.ColorIndex = sh.Range("f37").Offset(, y).DisplayFormat.Interior.ColorIndex
                    y = y + 1
                 Next cl
     
                MsgBox "Data gekopieerd naar aantal karren !", vbInformation, "Copy"
     
          End If
       
    End With

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    With Sheets("Jaarproductie m3 " & Year(sh.Range("E45")))
      r = Application.Match(sh.Range("e45"), .Columns(2), 0)
      If IsNumeric(r) Then
             .Cells(r, 3).Resize(, 7).Value = sh.Range("f38:m38").Value
           
For Each cl In .Cells(r, 3).Resize(, 7)
               cl.Interior.ColorIndex = sh.Range("f38").Offset(, y).DisplayFormat.Interior.ColorIndex
                y = y + 1
                Selection.ClearContents
'                range("E45").Activate
             Next cl
 
            MsgBox "Data gekopieerd naar aantal m3!", vbInformation, "Copy"
 
 
      End If
 
    End With
 
    sh.Range("E45") = ""                     'Cel leegmaken na opslaan data, zodat niet per ongeluk op een verkeerde datum terecht komt.
 Else
    MsgBox "er is geen datum ingevuld"       'Klikken zonder dat ingevuld
    sh.Range("E45") = ""
 
End If

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    With Sheets("Jaarproductie Elem.Kims " & Year(sh.Range("E45")))
             r = Application.Match(sh.Range("e45"), .Columns(2), 0)
             If IsNumeric(r) Then
           
             For j = 27 To 33
                For i = 12 To 24 Step 6
                  Select Case j
                        Case 27
                            If sh.Cells(j, i) > 0 Then
                                naam = sh.Cells(j, i - 5) & " " & sh.Cells(j, i - 4) & " " & sh.Cells(j, i - 3)
    '                            MsgBox naam
                             If i = 12 Then .Cells(r, 3).Resize(, 2) = Array(naam, sh.Cells(j, i))
                             If i = 18 Then .Cells(r + 1, 3).Resize(, 2) = Array(naam, sh.Cells(j, i))
                             If i = 24 Then .Cells(r + 2, 3).Resize(, 2) = Array(naam, sh.Cells(j, i))
                            End If
                           
                         Case 28
                            If sh.Cells(j, i) > 0 Then
                                   naam = sh.Cells(j, i - 5) & " " & sh.Cells(j, i - 4) & " " & sh.Cells(j, i - 3)
    '                               MsgBox naam
                                If i = 12 Then .Cells(r, 6).Resize(, 2) = Array(naam, sh.Cells(j, i))
                                If i = 18 Then .Cells(r + 1, 6).Resize(, 2) = Array(naam, sh.Cells(j, i))
                                If i = 24 Then .Cells(r + 2, 6).Resize(, 2) = Array(naam, sh.Cells(j, i))
                            End If
                         Case 29
                            If sh.Cells(j, i) > 0 Then
                                   naam = sh.Cells(j, i - 5) & " " & sh.Cells(j, i - 4) & " " & sh.Cells(j, i - 3)
    '                               MsgBox naam
                                If i = 12 Then .Cells(r, 9).Resize(, 2) = Array(naam, sh.Cells(j, i))
                                If i = 18 Then .Cells(r + 1, 9).Resize(, 2) = Array(naam, sh.Cells(j, i))
                                If i = 24 Then .Cells(r + 2, 9).Resize(, 2) = Array(naam, sh.Cells(j, i))
                            End If
                         Case 30
                            If sh.Cells(j, i) > 0 Then
                                   naam = sh.Cells(j, i - 5) & " " & sh.Cells(j, i - 4) & " " & sh.Cells(j, i - 3)
    '                               MsgBox naam
                                If i = 12 Then .Cells(r, 12).Resize(, 2) = Array(naam, sh.Cells(j, i))
                                If i = 18 Then .Cells(r + 1, 12).Resize(, 2) = Array(naam, sh.Cells(j, i))
                                If i = 24 Then .Cells(r + 2, 12).Resize(, 2) = Array(naam, sh.Cells(j, i))
                            End If
                         Case 31
                            If sh.Cells(j, i) > 0 Then
                                   naam = sh.Cells(j, i - 5) & " " & sh.Cells(j, i - 4) & " " & sh.Cells(j, i - 3)
    '                               MsgBox naam
                                If i = 12 Then .Cells(r, 15).Resize(, 2) = Array(naam, sh.Cells(j, i))
                                If i = 18 Then .Cells(r + 1, 15).Resize(, 2) = Array(naam, sh.Cells(j, i))
                                If i = 24 Then .Cells(r + 2, 15).Resize(, 2) = Array(naam, sh.Cells(j, i))
                            End If
                         Case 32
                            If sh.Cells(j, i) > 0 Then
                                   naam = sh.Cells(j, i - 5) & " " & sh.Cells(j, i - 4) & " " & sh.Cells(j, i - 3)
    '                               MsgBox naam
                                If i = 12 Then .Cells(r, 18).Resize(, 2) = Array(naam, sh.Cells(j, i))
                                If i = 18 Then .Cells(r + 1, 18).Resize(, 2) = Array(naam, sh.Cells(j, i))
                                If i = 24 Then .Cells(r + 2, 18).Resize(, 2) = Array(naam, sh.Cells(j, i))
                            End If
                         Case 33
                            If sh.Cells(j, i) > 0 Then
                                   naam = sh.Cells(j, i - 5) & " " & sh.Cells(j, i - 4) & " " & sh.Cells(j, i - 3)
    '                               MsgBox naam
                                If i = 12 Then .Cells(r, 21).Resize(, 2) = Array(naam, sh.Cells(j, i))
                                If i = 18 Then .Cells(r + 1, 21).Resize(, 2) = Array(naam, sh.Cells(j, i))
                                If i = 24 Then .Cells(r + 2, 21).Resize(, 2) = Array(naam, sh.Cells(j, i))
                            End If
                   End Select
                       
                       
                       
                       
                Next
               
                MsgBox "Data gekopieerd naar aantal Elementen.Kims!", vbInformation, "Copy"
               
       
             End If
               
    End With
    sh.Range("E45") = ""
Else

    MsgBox "in cel E45 moet een datum van het jaar 2024 staan"
    sh.Range("E45") = ""
End If
End Sub

AD1957 · 31 dec 2023

En wat is dan de fout ?, wat is de foutmelding?
Plaats een voorbeeldbestand.
Zeer waarschijnlijk wordt de data niet weggeschreven naar aantal elementen.

p.s.: een zip bestand kun je altijd plaatsen. lees https://www.helpmij.nl/forum/threads/lees-dit-voordat-u-een-vraag-plaatst.969663/

AD1957 · 31 dec 2023

Even terugkomend op de groene knop.
Deze opdrachtknop is een ActiveX besturingselement, zie onderstaande link voor uitleg.

Overzicht van formulieren, formulierbesturingselementen en ActiveX besturingselementen op een werkblad - Microsoft Ondersteuning

U kunt Excel-formulieren maken, bewerken, opmaken, vergrendelen en ontgrendelen, inclusief gegevensformulieren, werkbladen met formulier- en ActiveX-besturingselementen, en VBA-gebruikersformulieren.

support.microsoft.com

rogersmeets · 1 jan 2024

Het wegschrijven zou net als de aantal karren en aantal m3 met de knoppen 2 en 3 opgeslagen moeten worden, daar zou de code dus in moeten komen, dat heb ik geprobeerd in de code hierboven maar schrijft niets weg, en geeft meldingen dat de samenvoeging niet klopt if zonder End if, with zonder End with hoe meer ik bijvoeg of weghaal van deze woorden hoe meer meldingen.
Hier gaat het mis, ik zal straks een voorbeeld bestand uploaden

Next

MsgBox "Data gekopieerd naar aantal Elementen.Kims!", vbInformation, "Copy"

End If

End With
sh.Range("E45") = ""
Else

MsgBox "in cel E45 moet een datum van het jaar 2024 staan"
sh.Range("E45") = ""
End If
End Sub

rogersmeets · 1 jan 2024

in button 2 en 3 ingevoegd jou code 2 databladen uit 2023 even weggelaten anders was ie nog te groot, fouten die daardoor komen staan hier even los van.

AD1957 · 1 jan 2024

Roger,

k heb het aangepast, aan jou de schone taak om te achterhalen waarom het fout ging.
In de code voor het wegschrijven naar elementen heb ik nog iets extra's toegevoegd.
Als je nml. achteraf voor een bepaalde datum wijzigingen aanbracht (bij aantal karren naar 0) ging het fout.
Code verdient waarschijnlijk geen schoonheidsprijs maar het lijkt nu goed te werken.

rogersmeets · 1 jan 2024

AD1957 zei:
Roger,

k heb het aangepast, aan jou de schone taak om te achterhalen waarom het fout ging.
In de code voor het wegschrijven naar elementen heb ik nog iets extra's toegevoegd.
Als je nml. achteraf voor een bepaalde datum wijzigingen aanbracht (bij aantal karren naar 0) ging het fout.
Code verdient waarschijnlijk geen schoonheidsprijs maar het lijkt nu goed te werken.

je bent de beste het werkt 100 % hihi

rogersmeets · 2 jan 2024

Ik heb inmiddels de code voor elkaar om de middelste getallen op te zoeken en een aparte kleur te geven, nu werkt dat alleen als ik in de macro op start druk, hij zou het moeten doen als ik het werkblad open, dat zou hij moeten doen maar niet.

Code:

Private Sub Workbook_Open()
    Dim cel As Range
    Dim celWaarde As String
    Dim getallen() As String
    Dim middelsteGetal As String
    
    ' Loop door alle cellen in het actieve werkblad
    For Each cel In ActiveSheet.UsedRange
        ' Controleer of de celwaarde het specifieke formaat heeft
        If InStr(1, cel.Value, " ") > 0 And InStr(1, cel.Value, "CS") > 0 Then
            ' Splits de celwaarde op basis van spaties
            getallen = Split(cel.Value, " ")
            
            ' Controleer of er ten minste drie getallen zijn
            If UBound(getallen) >= 2 Then
                ' Het middelste getal is het tweede getal in de reeks
                middelsteGetal = getallen(UBound(getallen) - 1)
                
                ' Controleer het middelste getal en pas de kleur toe
                Select Case middelsteGetal
                    Case "643"
                        ' Het middelste getal markeren in de cel met rode kleur
                        cel.Characters(Start:=Len(getallen(0)) + 2, Length:=Len(middelsteGetal)).Font.Color = RGB(255, 0, 0) ' Rode kleur
                    Case "623"
                        ' Het middelste getal markeren in de cel met lichtblauwe kleur
                        cel.Characters(Start:=Len(getallen(0)) + 2, Length:=Len(middelsteGetal)).Font.Color = RGB(173, 216, 230) ' Lichtblauwe kleur
                    Case "598"
                        ' Het middelste getal markeren in de cel met paarse kleur
                        cel.Characters(Start:=Len(getallen(0)) + 2, Length:=Len(middelsteGetal)).Font.Color = RGB(128, 0, 128) ' Paarse kleur
                    Case "514"
                        ' Het middelste getal markeren in de cel met lichtgroene kleur
                        cel.Characters(Start:=Len(getallen(0)) + 2, Length:=Len(middelsteGetal)).Font.Color = RGB(144, 238, 144) ' Lichtgroene kleur
                    ' Voeg hier meer cases toe indien nodig
                End Select
            End If
        End If
    Next cel
End Sub

AD1957 · 2 jan 2024

De code hoort in een ander Event te staan.

Code:

Private Sub Workbook_Open()
'deze code werkt alleen bij openen van het bestand.
End Sub

rogersmeets · 2 jan 2024

hij werkt ik heb m anders geplaatst op deze werkmap in het event

Code:

Private Sub Worksheet_Change(ByVal Target As Range)

om welke reden past hij de kleur niet aan bij pers 7 ?
bij het hele formulier elementen en kims 2024 past hij de kleur aan op het moment dat er wat wordt bijgeschreven vanuit button 2 of 3, behalve p7 blijft zwart ????

pers 4 is me duidelijk omdat daar de indeling van de maten anders is dat komt goed vind ik wel uit

snb · 2 jan 2024

Ik vind het nogal ambitieus een overzicht ('dashboard') te maken zonder kennis van de verschillende soorten gebeurtenissencode.
Waarom niet eerst je de basisbeginselen van VBA in Excel eigen maken ?

In de macromodule van Sheet2:

CSS:

Private Sub Worksheet_Activate()
    For Each it In Range("C1,F1,I1,L1,O1,R1,U1").EntireColumn.SpecialCells(2)
      sn = Split(it)
      If UBound(sn) = 2 Then it.Characters(5, 3).Font.Color = Array(vbRed, vbCyan, vbMagenta, vbGreen)(InStr("643 623 598 514", sn(1) & " ") \ 4)
    Next
End Sub

Volgend opgave:
Alle algemene makro's, die nu in 8 verschillende macromodules staan in 1 macromodule onderbrengen of in de macromodule van het werkblad waarop de makro betrekking heeft.

AD1957 · 2 jan 2024

Als je die van pers 4 ook nog allemaal een kleurtje wilt geven wordt het een kleurenboek.
Zal zeker wel gaan, maar wat is hiervan de meerwaarde ?

snb · 2 jan 2024

IIn plaats van de funktie 'shift'.
Een named range 'dienst' met de volgende formule

PHP:

=INDEX({"nacht";"middag";"dag"};INT(MOD(TODAY()-44928;21)/7))

in de cel:

PHP:

=dienst

rogersmeets · 4 jan 2024

AD1957 zei:
Als je die van pers 4 ook nog allemaal een kleurtje wilt geven wordt het een kleurenboek.
Zal zeker wel gaan, maar wat is hiervan de meerwaarde ?

het overzicht in de getallen dacht ik

AD1957 · 4 jan 2024

Gokje, iets in deze richting ?
Worden wel veel kleurtjes, lijkt me eerder dat je het overzicht kwijt raakt.
Je kunt beter eens kijken naar een andere opzet van het blad ELEMENTEN.

Code:

Private Sub Worksheet_Activate()

Application.ScreenUpdating = False

For Each it In Range("C1,F1,I1,L1,O1,R1,U1").EntireColumn.SpecialCells(2)
                                                                       'geen L omdat er ook een steen is met hoogte 120
        If InStr(1, it, "L120", 1) > 0 Then it.Characters(InStr(1, it, "120", 1), 3).Font.Color = RGB(0, 250, 0)
        If InStr(1, it, "BD30", 1) > 0 Then it.Characters(InStr(1, it, "BD30", 1), 4).Font.Color = RGB(128, 0, 0)
        If InStr(1, it, "175*250", 1) > 0 Then it.Characters(InStr(1, it, "175*250", 1), 7).Font.Color = RGB(128, 0, 0)
        If InStr(1, it, "300*297", 1) > 0 Then it.Characters(InStr(1, it, "300*297", 1), 7).Font.Color = vbYellow
        If InStr(1, it, "150*300", 1) > 0 Then it.Characters(InStr(1, it, "150*300", 1), 7).Font.Color = RGB(128, 128, 128)
        If InStr(1, it, "514", 1) > 0 Then it.Characters(InStr(1, it, "514", 1), 3).Font.Color = vbGreen
        If InStr(1, it, "598", 1) > 0 Then it.Characters(InStr(1, it, "598", 1), 3).Font.Color = vbMagenta
        If InStr(1, it, "623", 1) > 0 Then it.Characters(InStr(1, it, "623", 1), 3).Font.Color = vbBlue
        If InStr(1, it, "643", 1) > 0 Then it.Characters(InStr(1, it, "643", 1), 3).Font.Color = vbRed
Next

Application.ScreenUpdating = True

End Sub

data wegschrijven naar een extern blad in een specifiek veld plaatsen

rogersmeets

Gebruiker

rogersmeets

Gebruiker

AD1957

Verenigingslid

AD1957

Verenigingslid

Overzicht van formulieren, formulierbesturingselementen en ActiveX besturingselementen op een werkblad - Microsoft Ondersteuning

rogersmeets

Gebruiker

rogersmeets

Gebruiker

Bijlagen

AD1957

Verenigingslid

Bijlagen

rogersmeets

Gebruiker

rogersmeets

Gebruiker

Bijlagen

AD1957

Verenigingslid

rogersmeets

Gebruiker

Bijlagen

snb

Verenigingslid

AD1957

Verenigingslid

snb

Verenigingslid

rogersmeets

Gebruiker

AD1957

Verenigingslid

Nieuwste berichten

Wij waarderen jouw privacy