• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Gegevens wegschrijven dmv lijst.

Status
Niet open voor verdere reacties.

danny147

Terugkerende gebruiker
Lid geworden
29 apr 2007
Berichten
4.744
Beste, ;)

Heb een sheet met 5000 rijen waarvan ik gegevens moet wegschrijven volgens een aantal ijsten.

In kolom AA staan 36 prioriteit 1 loopkranen, die op blad 2 moeten geplaatst worden.
In kolom AB staan 70 prioriteit 2 loopkranen, die op blad 3 moeten geplaatst worden.

Ik gebruik nu de volgende code die perfect werkt, enkel heb ik alle prioriteit 1 kranen er allemaal handmatig ingeplaatst.

Code:
Sub AA_Kranen_naar_blad2()
    Dim x      As Long
    Dim y      As Long
    Dim c      As Variant
    x = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
    y = 1
    For Each c In Range("C2:C2000")
[COLOR="#FF0000"]        If c = "LK100" Or c = "LK101" Or c = "LK103" Or c = "LK111" Or c = "LK120" _
        Or c = "LK121" Or c = "LK122" Or c = "LK132" Or c = "LK133" Or c = "LK135" _
        Or c = "LK145" Or c = "LK146" Or c = "LK310" Or c = "LK311" Or c = "LK401" _
        Or c = "LK402" Or c = "LK403" Or c = "LK404" Or c = "LK405" Or c = "LK100R" _
        Or c = "LK101R" Or c = "LK103" Or c = "LK111R" Or c = "LK120R" Or c = "LK121R" _
        Or c = "LK122R" Or c = "LK132R" Or c = "LK133R" Or c = "LK135R" Or c = "LK145R" _
        Or c = "LK146R" Or c = "LK310R" Or c = "LK311R" Or c = "LK401R" Or c = "LK402R" _
        Or c = "LK403R" Or c = "LK404R" Or c = "LK405R" Then[/COLOR]            
        c.Rows.EntireRow.Copy Sheets("Blad2").Range("A" & y).Offset(1, 0)
        y = y + 1
        c.Rows.EntireRow.Delete
        End If
    Next c
End Sub
Kan men de rode gemerkte code veranderen door te verwijzen naar AA kolom waar deze allemaal staan ("AA2:AA37") en ("AB2:AB71") ?

Groetjes Danny. :thumb:
 
Danny,

Ik probeer te begrijpen wat je wil bereikden, je wil in kolom C kijken en als de code van de loopkraan vermeld wordt in een lijst in reeks AA2:AA37 dan moet de regel gekopieerd worden naar Blad2 en als hij vermeld staat in reeks AB2:AB71 dan moet de regel gekopieerd worden naar Blad3.
Begrijp ik dit goed? Dan is er wel wat te maken in VBA.
 
Beste Elsendoorn2134 ;)

Bedankt voor de reactie.

Je begrijpt precies wat ik bedoel.

Het mag ook 2 aparte codes zijn.
1 voor het wegschrijven naar Blad2 en eentje voor het wegschrijven naar Blad3.

Groetjes Danny. :thumb:
 
Test het eens in een testbestandje Danny.
Code:
Sub AA_Kranen_naar_blad2()
    Dim cl      As Range
    Dim C       As Variant

For Each cl In Range("C2:C" & Cells(Rows.Count, 3).End(xlUp).Row)
    If cl > 0 Then
       Set C = Range("AA2:AB71").Find(cl, , xlValues, xlWhole)
       If Not C Is Nothing Then
      If Mid(C.Address, 3, 1) = "A" Then
         Sheets("Blad2").Cells(Rows.Count, 1).End(xlUp).Offset(1).EntireRow = cl.EntireRow.Value
        'cl.EntireRow.Delete
      Else
       Sheets("Blad3").Cells(Rows.Count, 1).End(xlUp).Offset(1).EntireRow = cl.EntireRow.Value
        'cl.EntireRow.Delete
     End If
    End If
   End If
 Next cl
End Sub
 
Beste HSV, ;)

Deze doet het jammer genoeg niet :confused:

Groetjes Danny. :thumb:
 
Laatst bewerkt:
Heb je het wel goed getest?, want mijn naam schrijf je i.i.g. verkeerd.
Je bent altijd vaste helper (geweest) Danny, maar met zo’n reactie kan/kon jezelf ook niets.
 
Laatst bewerkt door een moderator:
Beste HSV ;)

SORRY, SORRY en nogmaals SORRY, heb vorig bericht aangepast.

Bij het uitvoeren van de code, krijg ik enkel in Blad3 één regel met LK493.

Groetjes Danny. :thumb:
 
Komt het waarschijnlijk doordat er in de A kolom geen waarde staat?
Anders:
Code:
Sheets("Blad2").Cells(Rows.Count, [COLOR="#FF0000"]1[/COLOR]).End(xlUp).Offset(1).EntireRow =
in een 3 veranderen
voor beide regels code dus.
 
Beste HSV, ;)

Met de aanpassing van jou lukt het nu wel.

Nog een vraagje, wat als er in AC nog een lijst staat en deze moet naat Blad4 geschreven worden, wat is dan de aanpassing ?

Groetjes Danny. :thumb:
 
Laatst bewerkt:
Natuurlijk wil ik je wel helpen. :)

Ik zat er niet naast zo te zien.
Kolom A blijkt leeg te zijn.

Waar je om moet denken is de rode tekst.

Code:
Sub AA_Kranen__naar_blad2()
    Dim cl      As Range
    Dim C       As Variant

For Each cl In Range("C2:C" & Cells(Rows.Count, 3).End(xlUp).Row)
    If cl > 0 Then
       Set C = Range("[COLOR="#FF0000"]AA2:AB71[/COLOR]").Find(cl, , xlValues, xlWhole)
       If Not C Is Nothing Then
      If Mid(C.Address, 3, 1) = "[COLOR="#FF0000"][/COLOR][COLOR="#FF0000"]A[/COLOR]" Then [COLOR="#FF0000"]'wordt het in kolom AA gevonden ? dan[/COLOR]        
 Sheets("Blad2").Cells(Rows.Count, [COLOR="#FF0000"]3[/COLOR]).End(xlUp).Offset(1).EntireRow = cl.EntireRow.Value
        'cl.EntireRow.Delete
      Else [COLOR="#FF0000"]'anders in kolom AB dus[/COLOR]      
 Sheets("Blad3").Cells(Rows.Count, [COLOR="#FF0000"]3[/COLOR]).End(xlUp).Offset(1).EntireRow = cl.EntireRow.Value
        'cl.EntireRow.Delete
     End If
    End If
   End If
 Next cl
End Sub
 
Je hebt je bericht aangepast merk ik.

Code aangepast.
Code:
Sub AA_Kranen__naar_blad2()
    Dim cl      As Range
    Dim C       As Variant

For Each cl In Range("C2:C" & Cells(Rows.Count, 3).End(xlUp).Row)
    If cl > 0 Then
       Set C = Range("AA2:AC254").Find(cl, , xlValues, xlWhole)
       If Not C Is Nothing Then
 kolom = Mid(C.Address, 3, 1)
    Select Case kolom
      Case "A"
         Sheets("Blad2").Cells(Rows.Count, 3).End(xlUp).Offset(1).EntireRow = cl.EntireRow.Value
        'cl.EntireRow.Delete
      Case "B"
         Sheets("Blad3").Cells(Rows.Count, 3).End(xlUp).Offset(1).EntireRow = cl.EntireRow.Value
        'cl.EntireRow.Delete
      Case "C"
         Sheets("Blad4").Cells(Rows.Count, 3).End(xlUp).Offset(1).EntireRow = cl.EntireRow.Value
       End Select
     End If
   End If
 Next cl
End Sub
 
Beste HSV, ;)

Dat is wat ik nodig had.
Bedankt voor alles.

Groetjes Danny. :thumb:
 
Graag gedaan Danny. :thumb:
 
Het lijkt mij nogal tijdrovend om alle 5000 regels 1 voor 1 te doorlopen of er een prioriteit 1 of 2 staat vermeld.
M.i. is het beter om een filter te gebruiken en de zichtbare cellen naar de betreffende werkbladen te kopiëren.

Code:
Sub Sorteren()
Dim iTel As Integer
    Application.ScreenUpdating = False
    For iTel = 1 To 2
        With Range("A2:IV6000")
            .AutoFilter 26 + iTel, iTel
            With .SpecialCells(xlCellTypeVisible)
                .Copy Worksheets(iTel + 1).Range("A2")
                .EntireRow.Delete
            End With
        End With
    Next
    Application.ScreenUpdating = True
End Sub

Bovenstaande code filtert op waarde 1 in de AA-kolom en verplaatst de betreffende rijen naar het 2e werkblad.
Vervolgens wordt hetzelfde gedaan met waarde 2 in de AB-kolom. Deze rijen worden naar het 3e werkblad verplaatst.

Met vriendelijke groet,


Roncancio
 
Beste Roncancio, ;)

Ik krijg foutcode 400

Groetjes Danny. :thumb:
 
@Roncancio,

In kolom AA:AC staan geen 1’tjes of 2’tjes, maar het rode gedeelte van Danny‘s eerste post.
 
Bedankt voor de correctie.
Vandaar ook de foutmelding.

Met vriendelijke groet,


Roncancio
 
Beste HSV ;)

Ter aanvuling, zou ik graag het uitzicht willen zoals op Blad5.

Dat er boven elke regel waaar in kolom C een naam veranderd van LK, dat hij deze vermeld in de rij erboven in kolomA met de bijhorende teksten in de andere cellen en blauw gekleurd.

Vb. in cel C1 staat LK100, dat er een regel bovenaan wordt ingevoegd met in cel A1 LK100, A2 Roepnaam, cal A3 Machine enz...
In cel C4 staat LK101, dat er een regel bovenaan wordt ingevoegd met in cel C4 LK101 enz...

Is dit mogelijk ??

Bijlage bijgevoegd om het eventueel te testen.

Groetjes Danny. :thumb:
 

Bijlagen

Test het eens Danny?
Code:
Sub AA_Kranen__naar_blad2()
    Dim cl      As Range
    Dim C       As Variant
    
 sq = "Roepnaam" & "|" & "Machine" & "|" & "Omschrijving" & "|" & "Werkorder" & "|" & "Status" & "|" & "BeginTijdstipGepland" _
& "|" & "EindTijdstipGepland" & "|" & "CapacitaitsgroepID" & "|" & "Werkvoorbereider" & "|"
    
With Sheets("sheet1")
For Each cl In .Range("C2:C" & .Cells(Rows.Count, 3).End(xlUp).Row)

  If cl > 0 Then
       Set C = .Range("AA2:AC254").Find(cl, , xlValues, xlWhole)
       If Not C Is Nothing Then
 kolom = Mid(C.Address, 3, 1)
    Select Case kolom
    
 Case "A"
    With Sheets("Blad2").Cells(Rows.Count, 3).End(xlUp)
        If cl <> naam Then
         .Offset(1, -2).Resize(, 10).Interior.ColorIndex = 37
         .Offset(1, -2) = cl
         .Offset(1, -1).Resize(, 9) = Split(sq, "|")
        End If
       End With
    Sheets("Blad2").Cells(Rows.Count, 3).End(xlUp).Offset(1).Resize(, 7) = cl.Resize(, 7).Value
    
 Case "B"
    With Sheets("Blad3").Cells(Rows.Count, 3).End(xlUp)
        If cl <> naam Then
         .Offset(1, -2).Resize(, 10).Interior.ColorIndex = 37
         .Offset(1, -2) = cl
         .Offset(1, -1).Resize(, 9) = Split(sq, "|")
        End If
      End With
    Sheets("Blad3").Cells(Rows.Count, 3).End(xlUp).Offset(1).Resize(, 7) = cl.Resize(, 7).Value
      
 Case "C"
    With Sheets("Blad4").Cells(Rows.Count, 3).End(xlUp)
        If cl <> naam Then
         .Offset(1, -2).Resize(, 10).Interior.ColorIndex = 37
         .Offset(1, -2) = cl
         .Offset(1, -1).Resize(, 9) = Split(sq, "|")
        End If
      End With
    Sheets("Blad4").Cells(Rows.Count, 3).End(xlUp).Offset(1).Resize(, 7) = cl.Resize(, 7).Value
       
       End Select
     End If
   End If
   If Not cl Is Nothing Then
naam = cl
   End If
  Next cl
 End With
End Sub
 

Bijlagen

Beste HSV ;)

Dit is gewoon perfect wat je doet met VBA :d

Nu we toch bezig zijn, nog een vraagje :

Kan er gesorteerd worden op CapacitaitsgroepID per loopkraan ?
Zoadat 718.1 van boven staat dan 718.2 enz... oplopend dus.

Groetjes Danny. :thumb:
 

Bijlagen

Laatst bewerkt:
Status
Niet open voor verdere reacties.
Terug
Bovenaan Onderaan