VBA Loop werkt niet volledig.

Status
Niet open voor verdere reacties.
B

Bertjens48

Gebruiker
Lid geworden
22 okt 2018
Berichten
9
Hallo allen,

In het excel bestand wat gebruikt wordt voor de voorraad worden ook de geplaatste bestellingen bijgehouden. Er worden twee bladen voor gebruikt, een met nieuwe bestellingen "bestellijst" (blad2) en "Bestel history"(blad7). Als de geplande binnenkomst datum is verstreken wordt deze rij in kolom A voorzien van de term "oud", en moet deze verplaatst worden naar "bestel history". Het is van belang dat de volgorde waarin de producten staan behouden blijft in het nieuwe blad.

Er wordt nu gebruik gemaakt van onderstaande code. Deze werkt voor een groot gedeelte, maar nog niet 100%.
Zo lijkt het er op dat de loop cellen overslaat, Elke keer als een rij wordt verplaatst slaat hij de volgende cel over.
Daarnaast is de code ook vrij traag, is dit nog op te lossen.


Code: 
Private Sub CommandButton1_Click()
       
    Dim rij As Long
    Dim n As Long
    Dim src As Worksheet
    Dim trg As Worksheet

    Set src = Blad2
    Set trg = Blad7
    
    rij = trg.[A65536].End(xlUp).Row + 1
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    
    For n = 6 To Blad2.[A65536].End(xlUp).Row
    
        If Cells(n, "A").Value = "" Then Exit For
        
        If Cells(n, "A").Value = "Oud" Then
            Range(Cells(n, "B"), Cells(n, "Q")).Copy 'Kopieer kolom B t/m Q
            
            trg.Cells(rij, "A").PasteSpecial xlPasteValues
            Range(Cells(n, "A"), Cells(n, "Q")).EntireRow.Delete
            
            rij = rij + 1
        End If
    Next
        
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With
End Sub

Zouden jullie mij kunnen helpen met bovenstaande code?

Alvast bedankt.
 

Bijlagen

  • Loop Helpmij.xlsm
    35,9 KB · Weergaven: 37
rijen verwijderen doe je van onder naar boven. Draai de Loop maar eens om:
Code: 
For n =  Blad2.[A65536].End(xlUp).Row to 6 Step -1
 
Code: 
Private Sub CommandButton1_Click()
  With Blad2.ListObjects(1).DataBodyRange
    .AutoFilter 1, "Oud"
    .Copy Blad7.Cells(Rows.Count, 1).End(xlUp).Offset(1)
    .EntireRow.Delete
    .AutoFilter
  End With
End Sub
 
SjonR zei:
rijen verwijderen doe je van onder naar boven. Draai de Loop maar eens om:
Code: 
For n =  Blad2.[A65536].End(xlUp).Row to 6 Step -1
Klik om te vergroten...

Hoi SjonR.

Heb afgelopen tijd weinig tijd gehad om aan het bestand verder te werken vandaar mijn late reactie. Ik heb zojuist je aanpassingen door gevoerd en werkt nu naar behoren.

Bedankt.
 
Mooi dat ie nu werkt, maar heb je de door @snb aangedragen code al geprobeerd? Met een filter gaat het namelijk veeeeeeeeeel sneller.
 
Die heb ik zojuist ook even getest in een oudere versie.

De code werkt inderdaad sneller en ook volledig.
Ik loop hierbij tegen het volgende aan:
- Kolom A wordt ook gekopieerd. Met de huidige code wordt kolom B t/m Q gekopieerd. Kolom A is enkel om aan te geven of het om een oude order regel gaat, heeft daarna geen waarde meer.
- De opmaak wordt ook gekopieerd, is het mogelijk om dit zonder opmaak te kopieren?

Ik ga nog even verder puzzelen.

Bedankt.
 
Code: 
Private Sub CommandButton1_Click()
  With Blad2.ListObjects(1).DataBodyRange
    .AutoFilter 1, "Oud"
    .Offset(, 1).Copy
     Blad7.Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial -4163
    .EntireRow.Delete
    .AutoFilter
  End With
End Sub
 
Probeer het zo eens
Code: 
Private Sub CommandButton1_Click()
  With Blad2.ListObjects(1).DataBodyRange
    .AutoFilter 1, "Oud"
    .Offset(, 1).Resize(, 16).Copy
    Blad7.Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    .EntireRow.Delete
    .AutoFilter
  End With
End Sub

Edit @Jack Nouws was eerder.

Alternatief dan maar.
Code: 
Private Sub CommandButton1_Click()
  With Blad2.ListObjects(1).DataBodyRange
    .AutoFilter 1, "Oud"
    Blad7.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(.SpecialCells(12).Rows.Count, 16) = .Offset(, 1).SpecialCells(12).Value
    .EntireRow.Delete
    .AutoFilter
  End With
End Sub
 
Laatst bewerkt:
Mijn inbreng met resize…
Code: 
Private Sub CommandButton1_Click()
  With Blad2.ListObjects(1).DataBodyRange
    .AutoFilter 1, "Oud"
    .Offset(, 1).Resize(.SpecialCells(12).Rows.Count, .Columns.Count - 1).Copy
     Blad7.Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial -4163
    .EntireRow.Delete
    .AutoFilter
  End With
End Sub
Thx @ VenA
 
@Jack

Ik vermoed hetzelfde resultaat met:

Code: 
.Offset(, 1).Resize(, .Columns.Count - 1).Copy
 
Laatst bewerkt:
VenA, Jack nouws & snb.

Ik heb zojuist beide codes getest. En inderdaad de tweede code (met filter) werkt sneller dan de originele, deze ga ik dus ook gebruiken.

Mijn vraag is beantwoord, hartelijk dank.
 
Laatst bewerkt door een moderator:
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan