Opgelost Meerdere shapes in regel

[KeBr]

Beste,

Ik heb onderstaande stukje code in een groter geheel. Nu zou ik graag alle meetings in één rij hebben.
De startdatum is altijd in kolom 5 (E) de einddatum en de frequentie zou ik graag met een textbox doen.

Bv. startdatum is 27-2-2024, Als er dan een M staat in kolom 7 er een textbox met frequentie (aantal dagen) en einddatum.
Heb al bezig geweest met Step maar dit geeft foutmeldingen.

Case Is = "M"
'gevulde cirkel for Meetings. M in kolom 7
Set NewShp = ActiveSheet.Shapes.AddShape(msoShapeFlowchartConnector, Cells(r, LftCell).Left + 1, Cells(r, LftCell).Top + 1, Cells(r, LftCell).Width - 2, Cells(r, LftCell).Height - 2)
NewShp.Fill.ForeColor.RGB = fc
NewShp.Line.ForeColor.RGB = fc

 

[OctaFish]

Begin eens met een bestandje mee te sturen, zo kunnen we er weinig mee. En niemand hier gaat zelf eerst de situatie nabouwen.

 

[KeBr]

Beste OctaFish,

Dank voor je reactie. nu is er een bestandje toegevoegd. Onnodige voor dit heb ik eruit gehaald.
De regels 18 19 en 20 zijn waar het omgaat. Ik heb op basis van de startdatum het eerste bolletje geplaatst.
Nu zou ik willen dat er op de plaats van de kruisjes ook een zelfde bolletje komt. Er zijn nu 3 verschillende intervallen aangegeven. maar deze moeten flexibel zijn.
De einddatum staan nu hetzelfde als begindatum. In een textbox moet dan de juiste einddatum en de interval aangegeven kunnen worden.

Ik zie je reactie graag tegemoet.

 

[cow18]

in het blad "blad1" wordt er met de macro "test" wat shapes toegevoegd.
Ik veronderstel dat je op basis van die macro verder kan
Tiens, kan ik de macro-code zelf met de tags hier niet meer toevoegen ??

 

[snb]

Gebruik voorwaardelijke opmaak om een tijdsinterval grafisch weer te geven.

 

[KeBr]

Beste cow18,

Voor een groot deel krijg ik het wel werkend, echter wanneer ik
For i = 1 To Columns.Count \ 5 - 2 Columns.Count verander in een benoemde cel of kolom wordt alleen de eerste shape geplaatst. In mijn geval moet Columns.Count een datum worden die in rij 6 staat.

PS de macrocode kun je nog steeds teovoegen via de 3 puntjes naast afbeelding invoegen.

 

[snb]

@cow18

Onderschrijf mijn draad hier:

https://www.helpmij.nl/forum/threads/ongevraagd.971109/post-6382160

 

[cow18]

ik heb eventjes de macro herschreven van hoe het zou kunnen werken, dus hoe dat interval in jouw situatie moet werken, geen idee.Sub test()
Dim Dupl As Shape, NewShp As Shape, sh, c, c1
t = Timer
Application.ScreenUpdating = False
Set sh = Sheets("projectplanning") 'testblad
With sh
aa = .Rows(6).Value2


For Each shp In .Shapes
If shp.Name = "BlaBla" Then shp.Delete 'alle shapes met naam "BlaBla" verwijderen
Next

'sh.Range("3:6").Delete 'vorige shapes verwijderen
'Set c = sh.Cells(5, 1) 'begincel

For d1 = CLng(DateSerial(2023, 12, 1)) To CLng(DateSerial(2024, 4, 5)) Step 3 'ergens een gek interval opzetten = om de 3 dagen
If d1 Mod 2 Then 'en ergens nog een andere voorwaarde, dag is even, dus eigenlijk om de 6 dagen
r = Application.Match(d1, .Rows(6), 0) 'zoek die dag op in de rij 6
If IsNumeric(r) Then 'gevonden
Set c = .Cells(7, r) 'in deze cel komt je shape
If NewShp Is Nothing Then 'het is de eerste shape
Set NewShp = .Shapes.AddShape(msoShapeFlowchartConnector, c.Left + 1, c.Top + 1, c.Width - 2, c.Height - 2) 'beginshape
NewShp.Name = "BlaBla"
Else
Set Dupl = Nothing
Set Dupl = NewShp.Duplicate 'eerste shape dupliceren
DoEvents

With Dupl 'die shape
.Left = c.Left + 1 'verplaatsen
.Top = c.Top + 1
.Width = c.Width - 2 'vorm aanpassen
.Height = c.Height - 2
.Name = "BlaBla"
End With
End If
End If
End If
Next
End With

'Application.StatusBar = False
Application.CutCopyMode = False
'Application.Goto ActiveCell
Application.ScreenUpdating = True
'MsgBox i & " shapes" & vbLf & Format(Timer - t, "0.00\s") & vbLf & Format((Timer - t) / i * 1000, "0.0") & " sec per 1.000 shapes"
End Sub

 

[OctaFish]

@Cow: vergeten hoe je code tussen CODE tags zet? :d.

 

[cow18]

@OctaFish, nee, vergeten niet, maar het menu is gewijzigd. Vroeger koos ik "de 2e optie" (CCS???) in de opmaak maar die '/' blijft nu grijs, dus werd het dit maar ...
Eigenlijk blijft dat ganse lint hierboven bij mij grijs.

 

[Senso]

Sub test()
     Dim Dupl  As Shape, NewShp As Shape, sh, c, c1
     t = Timer
     Application.ScreenUpdating = False
     Set sh = Sheets("projectplanning")      'testblad
     With sh
aa = .Rows(6).Value2


          For Each shp In .Shapes
               If shp.Name = "BlaBla" Then shp.Delete 'alle shapes met naam "BlaBla" verwijderen
          Next

          'sh.Range("3:6").Delete                  'vorige shapes verwijderen
          'Set c = sh.Cells(5, 1)                  'begincel
    
          For d1 = CLng(DateSerial(2023, 12, 1)) To CLng(DateSerial(2024, 4, 5)) Step 3     'ergens een gek interval opzetten = om de 3 dagen
               If d1 Mod 2 Then             'en ergens nog een andere voorwaarde, dag is even, dus eigenlijk om de 6 dagen
                    r = Application.Match(d1, .Rows(6), 0) 'zoek die dag op in de rij 6
                    If IsNumeric(r) Then 'gevonden
                         Set c = .Cells(7, r) 'in deze cel komt je shape
                         If NewShp Is Nothing Then 'het is de eerste shape
                              Set NewShp = .Shapes.AddShape(msoShapeFlowchartConnector, c.Left + 1, c.Top + 1, c.Width - 2, c.Height - 2)     'beginshape
                              NewShp.Name = "BlaBla"
                         Else
                              Set Dupl = Nothing
                              Set Dupl = NewShp.Duplicate     'eerste shape dupliceren
                              DoEvents

                              With Dupl      'die shape
                                   .Left = c.Left + 1     'verplaatsen
                                   .Top = c.Top + 1
                                   .Width = c.Width - 2     'vorm aanpassen
                                   .Height = c.Height - 2
                                   .Name = "BlaBla"
                              End With
                         End If
                    End If
               End If
          Next
          End With

          'Application.StatusBar = False
          Application.CutCopyMode = False
          'Application.Goto ActiveCell
          Application.ScreenUpdating = True
          'MsgBox i & " shapes" & vbLf & Format(Timer - t, "0.00\s") & vbLf & Format((Timer - t) / i * 1000, "0.0") & " sec per 1.000 shapes"
     End Sub

 

[snb]

Zet eens in thisworkbook:

Sub M_snb()
  For Each it In Sheets
     MsgBox it.Shapes.Count
  Next
End Sub

3275 shapes in 1 werkblad is wat overdreven.....

 

[KeBr]

Beste Senso,

Ik heb het zo goed als werkend. De start en einddatum met InputBox gaat goed, evenals de interval
Alleen heb ik nog een probleem met:
Set c = .Cells(20, r) 'in deze cel komt je shape.
Het Row nummer moet eigenlijk de actieve Row zijn.
Ik heb dit ook al met InputBox geprobeerd maar dat gaat ook fout

 

[Senso]

Beste KeBr,
ik heb alleen de tekst cow18 in code gezet. snb, cow18 e.a. zijn de deskundigen op het gebied van Visual Basic for Applications.

 

[cow18]

mijn lint om te reageren is grijs !!!!

 

[cow18]

ik tik nu die tags er zelf maar in, kijken waar het schip strandt

1. rij 6 was dus geen goeie keuze, want in E6 staat een datum en als je net die datum een shape wil geven, zal die dus in kolom 5 terecht komen, daarom is rij 2 een veiliger keuze want in het bereik A2:J2 komen er geen datums voor.
2. Set c = .Cells(ActiveCell.Row, r), dus daar je activecell.row gebruiken, maar ik zou vroeger al eens getest hebben of je wel in het goeie tabblad en in het goeie bereik staat met

               r = Application.Match(d1, .Rows(2), 0)     'zoek die dag op in de rij 2 (vroeger de 6e rij, maar E6 herhaalt de waarde van C3, dus die datum gaat de mist in anders)
               If IsNumeric(r) Then          'gevonden
                    Set c = .Cells(ActiveCell.Row, r)     'in deze cel komt je shape

controle op werkblad en rijnummer bovenin de macro

   With sh
          If ActiveSheet.Name <> sh.Name Then MsgBox "je staat in het verkeerde blad", vbCritical: Exit Sub
          If Not (8 <= ActiveCell.Row And ActiveCell.Row <= 25) Then MsgBox "je staat niet in de goeie rijen", vbCritical: Exit Sub

 

[HSV]

Mijn beeld.

Maar geen "Citaten invoegen".

 

[Senso]

@cow18
Andere browser? Ik gebruik FF en dan is alles bruikbaar.

Is the [ ] grayed out? If not try clicking it.

 

[snb]

Klik in de bovenste rij op de 3 puntjes boven elkaar; in de volgende rij het tag symbool;: </>

 

[cow18]

gisterenavond, zonder zelf iets te doen, is het lint terug "vetjes" ipv grijs, dus het probleem is van de baan, hoe weet ik niet, maar dat is zonder belang.