waarde overnemen als er aan een voorwaarde is voldaan met VBA

[ewh]

Ik ben nu een paar weken bezig en HSV heeft me aardig op weg geholpen, maar het laatste stuk kom ik echt niet uit
het is wat complexer dan ik dacht
het is de bedoeling dat de monteur een weeklijst invult ( zie voorbeeld bestandje "weeklijst" ) daar in staat duidelijk de vraag beschreven
het komt er op neer dat we de uren van kolom H overmoeten nemen naar kolom F als in kolom E een getal staat beginnend met 4500
dit mag ook met VBA startend met een button

vervolgens wordt dmv van VBA het geheel gekopieerd naar tab blad "klad"( ook daar staat een beschrijving, van wat we willen )
we kopieren met VBA omdat er uiteindelijk meerdere weeklijsten gekopieerd worden Bekijk bijlage voorbeeldbestand weeklijsten.xls

ik hoop dat het lukt wat we willen

 

[VenA]

Probeer er eens een vraag van te maken. En als je al eerder door een vriendelijkere helper, zoals HSV, code aangereikt hebt gekregen zet dit dan in ook in het document.

daar in staat duidelijk de vraag beschreven

de kolom E wordt als laatste door de chef ingevuld
als er een nummer in komt te staan beginnend met 4500 dan moet in kolom F de waarde komen te staan van kolom H

Wat hier duidelijk aan is ontgaat mij.

Dus graag het bestand met code of wachten tot een ander er iets mee kan.

Nb. Met welke versie van Excel werken jullie?

 

[HSV]

In moduleblad 2 als je kolom E vult.

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns(5)) Is Nothing Then
 If Left(Target.Value, 4) = 4500 Then Target.Offset(, 1) = Target.Offset(, 3).Value
 End If
End Sub

De code om de gegevens van blad1 te scheiden zet je in een standaardmodule.

Sub hsv()
Dim sn, i As Long, j As Long, n As Long, x As Long
With Sheets("blad1")
 sn = .Cells(1).CurrentRegion
 ReDim arr(UBound(sn), 2)
 ReDim arr2(UBound(sn), 2)
 For i = 3 To UBound(sn)
   If Left(sn(i, 5), 4) = 4500 Then
     arr(n, 0) = sn(i, 7) & " - " & sn(i, 1)
     arr(n, 1) = sn(i, 6)
     arr(n, 2) = sn(i, 5)
            n = n + 1
   Else
     arr2(x, 0) = sn(i, 7) & " - " & sn(i, 1)
     arr2(x, 1) = sn(i, 6)
     arr2(x, 2) = sn(i, 5)
              x = x + 1
   End If
 Next i
   .Cells(3, 10).Resize(UBound(sn), 7).ClearContents
   .Cells(3, 10).Resize(UBound(arr2), 3) = arr2
   .Cells(3, 14).Resize(UBound(arr), 3) = arr
 End With
End Sub

Of sn reduceren.

Sub hsv()
Dim sn, i As Long, n As Long, x As Long
With Sheets("blad1")
 sn = .Cells(1).CurrentRegion
 ReDim arr(UBound(sn), 2)
 n = 1
 For i = 3 To UBound(sn)
   If Left(sn(i, 5), 4) <> 4500 Then
     sn(n, 1) = sn(i, 7) & " - " & sn(i, 1)
     sn(n, 2) = sn(i, 6)
     sn(n, 3) = sn(i, 5)
            n = n + 1
   Else
     arr(x, 0) = sn(i, 7) & " - " & sn(i, 1)
     arr(x, 1) = sn(i, 6)
     arr(x, 2) = sn(i, 5)
              x = x + 1
   End If
 Next i
   .Cells(3, 10).Resize(UBound(sn), 7).ClearContents
   .Cells(3, 14).Resize(UBound(arr), 3) = arr
   if n > 1 then .Cells(3, 10).Resize(n - 1, 3) = sn
 End With
End Sub

 

[ewh]

HSV bedankt
je hebt me geweldig geholpen , nu proberen te begrijpen wat je hebt gestuurd .

bedankt

 

[ewh]

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns(5)) Is Nothing Then
If Left(Target.Value, 4) = 4500 Then Target.Offset(, 1) = Target.Offset(, 3).Value
End If
End Sub

deze code gekregen van HSV en in het voorbeeld bestand werkt hij prima
het voorbeeld bestandje is een kopie van het grotere bestand
nu heb ik je code gekopieerd en in het juiste blad gezet en nu werkt hij niet? moet ik nog iets wijzigen? het is wel zo dat ik in het blad al een
Private Sub Worksheet_Change(ByVal Target As Range) heb staan, maar dat mag toch niet uitmaken?

 

[HSV]

Dat kan dus niet.

 

[ewh]

ik heb ze samen gevoegd en het werkt

bedankt allemaal