automatisch cellen samenvoegen dmv macro

[rvt1982]

Beste Leden,

Ik ben voor een bedrijf een (doorlopende) plannings agenda aan het maken.
nu moet ik voor verschillende personen een werkschema maken zodat iedereen kan zien waar ze moeten werken en op welke afdeling.

in het voorbeeld kan je zien hoe de planningsagenda er uit ziet (nog lang niet af)
via een database ook in excel 2003 kan ik al de weergave laten zien in de agenda, maar alleen automatisch een kleur geven is niet voldoende, dus wil ik in de gekleurde balk ook de naam van de betreffende persoon laten zien.
alleen omdat de planning per uur gaat worden de cellen vrij klein om daarin een hele naam in te zetten.

dus zoek een functie die bijvoorbeeld automatisch de cellen samenvoegen bijv. via macro.
Maar na elke wijziging in de data base moet de cellen ook weer aangepast zijn/worden.

alvast bedankt.

 

[HSV]

=TEKST.SAMENENVOEGEN(A1;B1;C1)
Maar het kan ook zo:
=A1&B1&C1
of:
=A1&" "& B1&" "C1

Maar met een .jpg extensie kunnen de meeste helpers niets.

 

[danny147]

Beste rvt1982

Kan je het bestandje hier plaatsen ?

Je kan ook kolommen maken waar je de uren ingeeft wanneer wie hoelang moet werken.
En deze dan overnemen met voorwaardelijke opmaak en de cellen kleuren.

Zie voorbeeldje dat ik heb geplaatst met jaarplanning.
Deze doet het met weken.

Groetjes Danny. :thumb:

 

[rvt1982]

@ Danny147 en HSV

jullie hebben gelijk ik had direct een goed voorbeeld moeten geven.
Voorbeeld excel: Bekijk bijlage VOORBEELD.xls

het voorbeeld van Danny147 is bijna precies het zelfde wat ik nu ook heb...
Maar wil ik in de gekleurde vlak de naam van de betreffende persoon, omdat bij mijn planning meerdere personen op 1 lijn kunnen staan.

Gr.

 

[danny147]

Beste rvt1982

Waarom schrijf je dan de namen niet onder elkaar ?

Je zegt: er kunnen meerdere personen op 1 lijn staan !
Daar ben ik mee akkoord, maar wat als ze de zelde tijd niet hebben ? (zie voorbeeld)

Op 1 lijn meerdere personen plaatsen, gaat voor mij onoverzichtelijk worden.
Wat als de uren over elkaar komen ?

Als je perse de naam erbij wilt hebben, dan moet het volgens mij met VBA gebeuren.
Dat laat ik dan over aan de experts op het forum hier.

Groetjes Danny. :thumb:

 

[rvt1982]

Beste danny147,

Daar zat ik ook aan te denken, maar ik moet een planning maken die 24 uur per dag loopt.
en het is hoofdzakelijk pluggedienst, dus er zijn ook medewerkers die bijvoorbeeld van 22:00 tot 6:00 werken en daarna dat een andere medewerken de taak overneemt.
vandaar ook de planning dat de namen in moeten zitten en dat meerdere medewerkers op 1 lijn kunnen staan.

bijv. pers1 werkt van 21:00 tot 6:00, pers2 die neemt zijn taak over van 6:00 tot 15:00, pers3 die neemt zijn taak over van 15:00 tot 21:00

dat is ook de grote probleem, het stopt niet bij 24 uur, dus als ik de namen onderelkaar zou zetten word deze bij veel personeel super lang..

ik weet dat het mogelijk is, omdat je wel een macro kan opnemen die de basic al doet.
alleen dit moet dan automatisch bij een wijzing van de database.

Maar ben super blij dat je met mij mee denkt.

Gr.

 

[popipipo]

Dit vbtje is misschien niet helemaal wat je wilt maar is misschien een alternatief als je niets verder vind. Of misschien voor een vba specialist om op voor te borduren.

 

[HSV]

Ik doe ook nog een gokje.

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim kolombegin As Integer, kolomeinde As Integer
   If Target.Address = "$E$4" Then
      Rows(3).UnMerge
       Rows(3).Clear
    kolombegin = WorksheetFunction.Match(Range("B4").Value, Range("G2:AD2"), 0) + 6
    kolomeinde = WorksheetFunction.Match(Range("C4").Value, Range("G2:AD2"), 0) + 6
      Range(Cells(3, kolombegin), Cells(3, kolomeinde)).Interior.ColorIndex = 3
     Range(Cells(3, kolombegin), Cells(3, kolomeinde)).Merge
    Cells(3, kolombegin) = Range("E4")
   Cells(3, kolombegin).HorizontalAlignment = xlVAlignCenter
  End If
End Sub

 

[rvt1982]

@Willem

Bedankt voor het alternatief.
zal ik zeker gebruiken als dit niet gaat werken

@Harry

Dit is wat ik zoek.... super, alleen moet dit zonder op enter te drukken moeten werken, omdat de info via een database krijgt. zoals =(A1)
zie voorbeeld

en de data komt via MARCO binnen
(in dit voorbeeldje staat de macro niet in.. )

Option Explicit

Private Sub Opslaan_Click()
Dim iRow As Long
Dim lPart As Long
Dim ws As Worksheet
Set ws = Worksheets("Database")

'find  first empty row in database
iRow = ws.Cells(Rows.Count, 1) _
  .End(xlUp).Offset(1, 0).Row

'check for a part number
If Trim(Me.Naam.Value) = "" Then
  Me.Naam.SetFocus
  MsgBox "Please enter a part number"
  Exit Sub
End If

'copy the data to the database
With ws
  .Cells(iRow, 1).Value = Me.Naam.Value
  .Cells(iRow, 2).Value = DateValue(Me.Datum)
  .Cells(iRow, 3).Value = Me.Machine.Value
  .Cells(iRow, 4).Value = Me.Melding.Value
  .Cells(iRow, 5).Value = Me.Van.Value
  .Cells(iRow, 6).Value = Me.Tot.Value

End With

'clear the data
Me.Naam.Value = "--Select--"
Me.Datum.Value = ""
Me.Van.Value = "--Select--"
Me.Tot.Value = "--Select--"
Me.Melding.Value = "--Select--"
Me.Machine.Value = "--Select--"
Me.Naam.SetFocus

End Sub

Private Sub Sluiten_Click()
  Unload Me
End Sub

Private Sub UserForm_Initialize()
Dim CNaam As Range
Dim CWerktijdVanaf As Range
Dim CWerktijdTot As Range
Dim CMelding As Range
Dim cPart As Range
Dim Cmachine As Range
Dim ws As Worksheet
Set ws = Worksheets("Gegevens")

'Naam tabel
For Each CNaam In ws.Range("Naam")
  With Me.Naam
    .AddItem CNaam.Value
  End With
Next CNaam

'TijdVanaf tabel
For Each CWerktijdVanaf In ws.Range("WerktijdVanaf")
  With Me.Van
    .AddItem CWerktijdVanaf.Value
    .List(.ListCount - 1, 1) = CWerktijdVanaf.Offset(0, 1).Value
  End With
Next CWerktijdVanaf

'TijdTot tabel
For Each CWerktijdTot In ws.Range("WerktijdTot")
  With Me.Tot
    .AddItem CWerktijdTot.Value
    .List(.ListCount - 1, 1) = CWerktijdTot.Offset(0, 1).Value
  End With
Next CWerktijdTot

'Melding tabel
For Each CMelding In ws.Range("Melding")
  With Me.Melding
    .AddItem CMelding.Value
  End With
Next CMelding

'Machine tabel
For Each Cmachine In ws.Range("Machine")
  With Me.Machine
    .AddItem Cmachine.Value
  End With
Next Cmachine

'Opstart scherm
Me.Naam.Value = "--Select--"
Me.Datum.Value = ""
Me.Van.Value = "--Select--"
Me.Tot.Value = "--Select--"
Me.Melding.Value = "--Select--"
Me.Machine.Value = "--Select--"
Me.Naam.SetFocus

End Sub

 

[HSV]

Test deze eens.

Bij een Worksheet_activate gaat de code lopen.
Dus even een kijkje nemen op blad 'Agenda' daarna even naar 'AgendaData'en weer terug.

Ik hoop dat dit de bedoeling is.

Private Sub Worksheet_Activate()
 Dim cl As Range, c As Variant, rij As Integer, q As Variant, nummer As Integer
   With Sheets("Agenda").Range("B4:FM24")
    .ClearContents
    .Interior.ColorIndex = xlNone
    .UnMerge
   End With
With Sheets("AgendaData")
  For Each cl In .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    If cl > 0 Then
 With Sheets("Agenda")
   .Columns("B:FM").ColumnWidth = 45
      Set c = .Range("B2:FM2").Find(cl.Offset(, 1), LookIn:=xlValues)
   .Columns("B:FM").ColumnWidth = 3
     rij = WorksheetFunction.Match(cl.Offset(, 2), .Range("A1:A24"), 0)
 End With

If Not c Is Nothing Then
  nummer = 1
   Do Until nummer = 24
       If Range(c.Address).Offset(1, nummer).Value = cl.Offset(, 3) Then
   q = IIf(cl.Offset(, 4) < cl.Offset(, 3), cl.Offset(, 4) + 24 - cl.Offset(, 3), _
   cl.Offset(, 4) - cl.Offset(, 3))
  
   If Range(c.Address).Offset(rij - 2, nummer) <> "" Then
      rij = rij + Range(c.Address).Offset(rij - 2, nummer).End(xlDown).Rows.Count
        Range(c.Address).Offset(rij - 2, nummer) = cl
         Range(c.Address).Offset(rij - 2, nummer).HorizontalAlignment = xlVAlignCenter
          Range(c.Address).Offset(rij - 2, nummer).Resize(, q).Interior.ColorIndex = 3
           Range(c.Address).Offset(rij - 2, nummer).Resize(, q).Merge
    Else
       Range(c.Address).Offset(rij - 2, nummer) = cl
        Range(c.Address).Offset(rij - 2, nummer).HorizontalAlignment = xlVAlignCenter
         Range(c.Address).Offset(rij - 2, nummer).Resize(, q).Merge
           Range(c.Address).Offset(rij - 2, nummer).Resize(, q).Interior.ColorIndex = 3: Exit Do
          End If
         End If
        nummer = nummer + 1
      Loop
     End If
    End If
   Next
  End With
End Sub

 

[rvt1982]

Best Harry,

dit ziet er zeker goed uit.
alleen zodra er meer dan 2 personen met de zelfde tijd werken, dan laat deze alleen de 1e en de laaste zien de rest komt dan niet meer in de agenda voor.
is daar ook iets voor ??

Is het ook mogelijk dat er bij een wijziging van de data dat dan de code gaat lopen?? (zonder op enter te drukken)
als dit niet mogelijk is, denk ik dat het dan het makkelijkste is met een knop "Update/Ververs"
omdat deze mensen veel in 1 scherm/blad werken

ik durf je bijna niks meer te vragen omdat je mij al zo veel hebt geholpen..
maar ben erg blij met je hulp en kan je hulp goed gebruiken..

 

[HSV]

Kleine aanpassing; extra rij ingevoegd; 'currentregion' toegepast.

Zet de code eens in een Change_Event in Moduleblad 'AgendaData'.

 

[rvt1982]

De Change_Event in Moduleblad 'AgendaData' werkt bij mij niet.. maar kan ook aan mij liggen

had nog een foutje gevonden..
als je van "jan 15-08-2011" de tijd aanpast van 8 tot 17 naar 7 tot 17, dan gaat het mis.
maar krijg ook een fout melding als je van "jan 15-08-2011" de tijd aanpast van 8 tot 17 naar 1 tot 9, dan gaat het ook fout.
ik kan hier de fout ook niet invinden, maar dat komt waarschijnlijk te weinig ervaring in VBA

:thumb:

 

[HSV]

Iets andere opzet.
Maximaal 5 prs/oven/dg.
Als het er meer zijn dan moet je rijen invoegen.

 

[rvt1982]

Beste Harry,

Deze is bijna perfect...
de foutjes wat hij nog heeft is dat bij de tijd 1uur staat is deze persoon niet meer in de agenda.
en door de extra kolom word de tijd vanaf dag2 ook 1uur opgeschoven..

en als het mogelijk is de kolom/rij (verticaal) verstoppen(ivm de rij nummer), mij lukt het niet, omdat de code deze steeds terug brengt naar 26pix

de autom. update werkt ook niet, misschien moeten we daar toch een knop voor maken.

Thnx

 

[HSV]

Hierbij een vernieuwde versie.
Als je nu iets veranderd in 'AgendaData' dan start de code, maar alleen met Enter.

 

[rvt1982]

Weer bedankt voor de moeite en de vernieuwde versie.
dit ziet er weer beter uit.

als de tijd planning van "1 uur" ook werkt dan is deze helemaal klaar..

Thnx

 

[HSV]

Bedoel je als iemand maar 1 uur werkt?

 

[rvt1982]

nee, als iemand van 1 tot ... uur werkt dan is deze niet in de agenda aanwezig.

 

[HSV]

Edit: Ik zal er nog eens weer induiken.