Kopieeren en plakken

[josdebrouwer]

Hey,

Ik heb een groot bestand, elke rij is een uur productie in dit geval(in het vb zijn het dagen)

De productie is normaal in 3 ploegen, dus niet in het weekend.

Ook vallen er wel eens ploegen uit, bv een hele week geen nacht dient.

Soms lopen we voor en soms lopen we achter op het plan, dan moet ik alle weer goed zetten door middel kopiëren en plakken.

Is er een handige manier om dit te doen?

Zie voorbeeld.

 

[Senso]

Voorbeeld?

 

[josdebrouwer]

voorbeeld

vergeten, hiet het vb

 

[SjonR]

Om WAT te doen?

 

[Roelof1983]

ik heb voor de weekplanning een basissheet die ik beveilig en verberg. Die kopieer ik en daarin ga ik knutselen en doen om de planning rond te krijgen.
Mocht ik er niet uit komen, hoef ik alleen maar de huidige sheet te verwijderen en de basissheet te kopieeren. Wellicht een idee?
Of bedoel je dat niet?

 

[SjonR]

Dus je wilt de rechterkolom weer als standaard hebben? Sla het dan op als... Save as..... dan kan je altijd terug naar de basis

 

[josdebrouwer]

kopiëren en plakken

Als we inlopen op het plan moet ik alles naar boven kopiëren

ik zoek een manier om makkelijker de kopiëren en te plakken. omdat er cellen leeg moeten blijven is het meer werk om dat te doen.

 

[VenA]

Onduidelijk voorbeeld. Waarom gaat 140500 niet naar 4-1-2018. 'De productie is normaal in 3 ploegen, dus niet in het weekend.' vreemde conclusie. Maak er eerst een goede vraag van en plaats een representatief voorbeeld.

 

[HSV]

Draai onderstaande code eens @VenA, dan wordt het wel duidelijk voor je,

Sub hsv()
Dim sv, i As Long, n As Long, j As Long
sv = Split(Application.Trim(Join(Application.Transpose(Range("b1:b100")))))
ReDim arr(0)
  For i = 1 To 36
     If n = 0 Then
       arr(n) = sv(j)
       j = j + 1
      Else
        If Cells(i, 2).Interior.ColorIndex <> 3 Then
          If j <= UBound(sv) Then
            If arr(n - 1) = sv(j) Or arr(n - 1) = "" Then
              arr(n) = sv(j)
                   j = j + 1
            End If
          End If
        End If
    End If
   n = n + 1
   ReDim Preserve arr(n)
 Next i
Cells(1, 7).Resize(36) = Application.Transpose(arr)
End Sub

 

[josdebrouwer]

Kopiëren en plakken

Hey,

Is dus mogelijk, werkt super.

hartelijk bedankt.

Nu wil ik dit in het gebruikers bestand zetten, maar kom er niet helemaal aan uit.

Zou je deze kunnen aanpassen zodat deze werkt in mijn sheet?

Ik snap de code niet, probeer deze wel te lezen, klopt het dat om het te laten werken de cellen wel rood moeten zijn?Bekijk bijlage Kopieeren en plakken 1.xlsm

 

[HSV]

Je moet wel wat geduld hebben bij dit bestand (traag,koppelingen ed.)

Je kan met onderstaande code met meerdere kleuren werken als je dat wilt.

Sub hsv()
Dim sv, sv2, hs, i As Long, n As Long, j As Long, jj As Long
hs = Range("A6", Cells(Rows.Count, 1).End(xlUp)).Resize(, 9)
For j = 4 To 8 Step 2
 ReDim arr(1, 0)
 sv = Split(Application.Trim(Join(Application.Transpose(Application.Index(hs, 0, j)))))
 sv2 = Split(Application.Trim(Join(Application.Transpose(Application.Index(hs, 0, j + 1)))))
  For i = 6 To UBound(hs)
     If n = 0 Then
       arr(0, n) = sv(jj)
       If UBound(sv2) <> -1 Then arr(1, n) = sv2(jj)
       jj = jj + 1
      Else
        If Cells(i, j).Interior.ColorIndex = xlnone Then
          If jj <= UBound(sv) Then
            If arr(0, n - 1) = sv(jj) Or arr(0, n - 1) = "" Then
              arr(0, n) = sv(jj)
               If UBound(sv2) <> -1 Then arr(1, n) = sv2(jj)
                  jj = jj + 1
            End If
          End If
        End If
    End If
   n = n + 1
   ReDim Preserve arr(1, n)
 Next i
Cells(6, j).Resize(n, 2) = Application.Transpose(arr)
n = 0
jj = 0
Next j
End Sub

In een keer wegschrijven ipv 3x kan ook.

Sub hsv()
Dim sv, sv2, hs, i As Long, n As Long, j As Long, jj As Long
hs = Range("A6", Cells(Rows.Count, 1).End(xlUp)).Resize(, 9)
ReDim arr(5, UBound(hs))
    For j = 4 To 8 Step 2
     n = 0
     jj = 0
     sv = Split(Application.Trim(Join(Application.Transpose(Application.Index(hs, 0, j)))))
     sv2 = Split(Application.Trim(Join(Application.Transpose(Application.Index(hs, 0, j + 1)))))
      For i = 6 To UBound(hs)
         If n = 0 Then
             arr(j - 4, n) = sv(jj)
             If UBound(sv2) <> -1 Then arr(j - 3, n) = sv2(jj)
             jj = jj + 1
          Else
            If Cells(i, j).Interior.ColorIndex = xlNone Then
              If jj <= UBound(sv) Then
                If arr(j - 4, n - 1) = sv(jj) Or arr(j - 4, n - 1) = "" Then
                  arr(j - 4, n) = sv(jj)
                   If UBound(sv2) <> -1 Then arr(j - 3, n) = sv2(jj)
                      jj = jj + 1
                End If
              End If
            End If
        End If
       n = n + 1
     Next i
    Next j
Cells(6, 4).Resize(UBound(hs), 5) = Application.Transpose(arr)
End Sub

 

[josdebrouwer]

Kopiëren en plakken

hey,

Werkt super, zeer blij mee.

bedankt.