Data verzamelen met loop

[wiki]

Hoe maak een rijverwijzing variabel in een loop?

Per regel staat de staminfo: locatie, datum en meerdere artikelen en aantallen. Voor iedere uitgifte moet een aparte regel gemaakt worden omdat deze informatie weer elders gebruikt moet worden.

Ik wil graag met een loop nieuwe rijen aanmaken voor de kolommen met andere artikelen.

De info in kolom H:L moet in de eerste lege rij in kolom A:G gezet worden en dit geld ook voor de andere artikelen. De waarden i de gele cellen worden overgeneomen uit de eerste kolommen, maar zijn in werkelijkheid leeg en worden gevuld met een macro.

Het aantal rijen is dynamisch

Wie kan helpen

 

[Warme bakkertje]

Beste Wiki, je vraag is al 30x bekeken en je bestand al 6x geopend en nog steeds geen reacties. Ik vrees dat je je vraag toch zal moeten verduidelijken want hier zitten genoeg formule- en VBAexperts voor wie geen uitdaging te groot is maar die nu om een of andere reden afhaken

 

[wiki]

Bij deze dan een poging de vraag te verhelderen. Ik heb een exportbestand/ rapportage in een database die ik in deze weergave niet kan gebruiken.
Iedere regel bevat meerdere kolommen met verkoopinformatie maw meer artikelen.
Ik wil graag in iedere regel de informatie van de verkopen per dag van 1 artikel.
Dat betekent dat iedere bestaande regel een aantal keren gekopieerd moet worden naar een nieuwe regel waarbij de kolom artikel een "volgende kolom (vaste verschuiving)" is.
Het aantal regels is variabel.

Als dit de vraag niet verduidelijkt kunnen jullie dan specifiek aangeven wat onduidelijk is?

gr Wim

 

[snb]

Wellicht heb je hier iets aan.

 

[wiki]

Ik denk dat het het eenvoudigst is om met een loop iedere rij een aantal keer te kopieren naar een ander blad met iedere keer een range waarin maar 1 artikel voorkomt. Vandaag wat gegoogeld en de volgende code samengesteld:

Application.Calculation = xlManual
Application.ScreenUpdating = False


Set currentCell = Range("a2")
Do While Not IsEmpty(currentCell)
Set nextCell = currentCell.Offset(1, 0)
Sheets("Blad1").Range("a16,b16,e16").Copy [Blad2!a65536].End(xlUp).Offset(1, 0)
Sheets("Blad1").Range("a16,c16,f16").Copy [Blad2!a65536].End(xlUp).Offset(1, 0)
Set currentCell = nextCell
Loop
Range("a1").Select

Application.Calculation = xlAutomatic
Application.ScreenUpdating = True

wat ik nog moet doen en wat niet lukt is om de rij variabel te maken.

Wie kan helpen?

gr wim

 

[wiki]

Stel ik mijn vraag verkeerd of is het verzoek onlogisch?

gr wim

 

[Warme bakkertje]

Neen, maar je bestand is niet te openen zodat we niks hebben om mee te werken

 

[wiki]

@2 warm bakkertje, hoe kan dat dan als deze 6 keer geopend is?

gr wim

 

[Wigi]

@2 warm bakkertje, hoe kan dat dan als deze 6 keer geopend is?

gr wim

Neen, gedownload.

 

[trucker10]

hoe kan dat dan als deze 6 keer geopend is?

gr wim

Ik krijg een blanco webpagina blijkbaar wat problemen op het forum de laatste dagen

 

[wiki]

Nieuwe bijlage met de macro "verplaats". In werkelijkheid zijn het >50 afdelingen dus misschien is een controle handig als cel .. in varibale rij waarde bevat dan..

gr wim

 

[wiki]

Kan ik deze code ombouwen van rijen naar kolommen?

intersect(columns(activecell.column),union(rows(11),rows(13),rows(23),rows(27))).select

Ik heb rows en row vervangen door column en columns
en later de cijfers door letters en later ook tussen aanhalingstekens, maar zonder het gewenste resultaat.

gr Wim

 

[Warme bakkertje]

Intersect(Rows(ActiveCell.Row), Union(Columns(3), Columns(5), Columns(7), Columns(9))).Select

 

[wiki]

Bedankt warm bakkertje, volgens mij ben ik nu aardig op weg, ga verder puzzelen.

gr wim

 

[wiki]

Sub Loop1()


    Do
   
        If IsEmpty(ActiveCell.Offset(0, 7)) = False Then
   Intersect(Rows(ActiveCell.Row), Union(Columns(1), Columns(2), Columns(3), Columns(4), Columns(5), Columns(6), Columns(7))).Copy [Blad2!a65536].End(xlUp).Offset(1, 0)
   
      If IsEmpty(ActiveCell.Offset(0, 9)) = False Then
   Intersect(Rows(ActiveCell.Row), Union(Columns(1), Columns(2), Columns(3), Columns(4), Columns(5), Columns(8), Columns(9))).Copy [Blad2!a65536].End(xlUp).Offset(1, 0)
   
    If IsEmpty(ActiveCell.Offset(0, 11)) = False Then
   Intersect(Rows(ActiveCell.Row), Union(Columns(1), Columns(2), Columns(3), Columns(4), Columns(5), Columns(10), Columns(11))).Copy [Blad2!a65536].End(xlUp).Offset(1, 0)
   
  If IsEmpty(ActiveCell.Offset(0, 13)) = False Then
   Intersect(Rows(ActiveCell.Row), Union(Columns(1), Columns(2), Columns(3), Columns(4), Columns(5), Columns(12), Columns(13))).Copy [Blad2!a65536].End(xlUp).Offset(1, 0)
  
   If IsEmpty(ActiveCell.Offset(0, 15)) = False Then
   Intersect(Rows(ActiveCell.Row), Union(Columns(1), Columns(2), Columns(3), Columns(4), Columns(5), Columns(14), Columns(15))).Copy [Blad2!a65536].End(xlUp).Offset(1, 0)
  
   If IsEmpty(ActiveCell.Offset(0, 17)) = False Then
   Intersect(Rows(ActiveCell.Row), Union(Columns(1), Columns(2), Columns(3), Columns(4), Columns(5), Columns(16), Columns(17))).Copy [Blad2!a65536].End(xlUp).Offset(1, 0)
  
  If IsEmpty(ActiveCell.Offset(0, 19)) = False Then
   Intersect(Rows(ActiveCell.Row), Union(Columns(1), Columns(2), Columns(3), Columns(4), Columns(5), Columns(18), Columns(19))).Copy [Blad2!a65536].End(xlUp).Offset(1, 0)
  
  If IsEmpty(ActiveCell.Offset(0, 21)) = False Then
   Intersect(Rows(ActiveCell.Row), Union(Columns(1), Columns(2), Columns(3), Columns(4), Columns(5), Columns(20), Columns(21))).Copy [Blad2!a65536].End(xlUp).Offset(1, 0)

 If IsEmpty(ActiveCell.Offset(0, 23)) = False Then
    Intersect(Rows(ActiveCell.Row), Union(Columns(1), Columns(2), Columns(3), Columns(4), Columns(5), Columns(22), Columns(23))).Copy [Blad2!a65536].End(xlUp).Offset(1, 0)
   
  If IsEmpty(ActiveCell.Offset(0, 25)) = False Then
   Intersect(Rows(ActiveCell.Row), Union(Columns(1), Columns(2), Columns(3), Columns(4), Columns(5), Columns(24), Columns(25))).Copy [Blad2!a65536].End(xlUp).Offset(1, 0)

  If IsEmpty(ActiveCell.Offset(0, 27)) = False Then
   Intersect(Rows(ActiveCell.Row), Union(Columns(1), Columns(2), Columns(3), Columns(4), Columns(5), Columns(24), Columns(27))).Copy [Blad2!a65536].End(xlUp).Offset(1, 0)
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If


    ActiveCell.Offset(1, 0).Select

    Loop Until IsEmpty(ActiveCell.Offset(1, 0))

End Sub

Ik heb de loop aangepast want deze werkte niet meer. Wat nog niet werkt is het negeren van lege cellen. Wat moet ik veranderen aan de regel:

 If IsEmpty(ActiveCell.Offset(0, 27)) = False Then

gr wim

 

[wiki]

denk dat het opgelost is telde alle kolommen en niet de verschuiving dus zat een kolom te ver

gr wim

 

[Warme bakkertje]

Sub tst()
    For Each c In Range("A2", [A65536].End(xlUp))
        For j = 6 To 26 Step 2
            If c.Offset(0, j).Value <> "" Then
                c.Resize(1, 5).Copy [Blad2!A65536].End(xlUp).Offset(1, 0)
                c.Offset(0, j - 1).Resize(1, 2).Copy [Blad2!F65536].End(xlUp).Offset(1, 0)
            End If
        Next j
    Next c
End Sub

 

[snb]

Is het niet eenvoudiger alles te kopiëren naar Blad2 en in Blad2 te verwijderen wat verwijderd moet worden.

 

[wiki]

Bedankt heren:thumb:

gr wim