Kopiëren en plakken op juiste regel/achter juiste tekst

[CygneVoler]

Beste forumleden,
Ik heb een database met artikelen (tabblad DB_PRODUCTEN)
Door middel van het invoeren van het artikelnummer op een bestellijst worden d.m.v. verticaal zoeken het artikelen geplaatst vanuit de DB_producten.
Het aantal wat besteld moet worden wordt handmatig ingevoerd op de bestellijst evenzo besteld door.
Wanneer je op de button ‘Bestellen’ drukt wordt de bestelling in het overzicht geplaatst.
Ik krijg het echter niet voor elkaar om het bestelde aantal in de kolom ‘besteld’ van de DB_producten, te plaatsen bij het juist artikelregels.
Graag jullie hulp.

de volgende code gebruik ik voor het kopieren:

Private Sub Bestellen_Click()
  
  EW = Sheets("bestellijst").Cells(2, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row - 1, 6)
  ReDim arr(UBound(EW) - 1, 6)
    For i = 2 To UBound(EW)
       For Each j In Array(1, 2, 3, 4, 5, 6)
            arr(i - 2, jj) = EW(i, j)
            jj = jj + 1
       Next j
      jj = 0
     Next i
       With Sheets("Besteloverzicht").Cells(Rows.Count, 1).End(xlUp)
                .Offset(1).Resize(UBound(arr), 6) = arr
    
    With Sheets("DB_Producten").Cells(Rows.Count, 1).End(xlUp)
                
         End With
         End With

End Sub

 

[SjonR]

zo?

Private Sub Bestellen_Click()
  
  EW = Sheets("bestellijst").Cells(2, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row - 1, 6)
  ReDim arr(UBound(EW) - 1, 6)
    For i = 2 To UBound(EW)
       For Each j In Array(1, 2, 3, 4, 5, 6)
            arr(i - 2, jj) = EW(i, j)
            jj = jj + 1
       Next j
      jj = 0
     Next i
       With Sheets("Besteloverzicht").Cells(Rows.Count, 1).End(xlUp)
                .Offset(1).Resize(UBound(arr), 6) = arr
       End With

For Each cl In Sheets("DB_PRODUCTEN").Range("A2:A9")
If Application.CountIf(Sheets("BESTELLIJST").Columns(1), cl) > 0 Then
cl.Offset(0, 4).Value = Sheets("BESTELLIJST").Columns(1).Find(cl.Value).Offset(0, 3).Value
End If
Next

End Sub

 

[CygneVoler]

SjonR, het ziet er veel belovend uit! Dank voor je snelle reactie!
Nu heb ik natuurlijk voorbeeld gemaakt wat op het 'orgineel' moet lijken.
Zo heb ik bijvoorbeeld niet 9 regels in kolom A (A1:A9) maar bijvoorbeeld 999
En ligt de kolom van DB_PRODUCTEN waar het aantal naar wordt gekopieerd, niet op 4 maar op 24!
Wanneer ik dit dan wijzig zie ik niets gebeuren in het 'orgineel".
Is daar een verklaring voor?

For Each cl In Sheets("DB_PRODUCTEN").Range("A2:A999")
If Application.CountIf(Sheets("BESTELLIJST").Columns(1), cl) > 0 Then
cl.Offset(0, 24).Value = Sheets("BESTELLIJST").Columns(1).Find(cl.Value).Offset(0, 5).Value

 

[SjonR]

Plaats dan even het echte bestand aub

 

[CygneVoler]

Dat ligt wat gevoelig omdat er elementen in zijn opgenomen die bedrijfsgevoelig zijn. Dus als wij het zo zouden kunnen oplossen zou ik daar heel blij mee zijn.
Ik hoop op je begrip.

 

[SjonR]

Ik zal er morgen nog eens naar kijken, als niemand mij voor is. Ik zit nu in de kroeg

 

[CygneVoler]

Dat is het betere werk SjonR!
Ik heb een aangepast document gemaakt. Ik hoor het graag.
Hele fijne avond!
En...glaasje op...

 

[CygneVoler]

Ik heb een beetje zitten suffen denk ik want ik heb me vergist in de kolom! Dus het probleem lijkt opgelost!

 

[SjonR]

mooi! :thumb:

 

[VenA]

Blijkbaar een slechte kroeg:d

 

[CygneVoler]

Dat hoop ik niet VenA!

Bedankt voor jullie ondersteuning.

 

[VenA]

Het echte bestand bevat beveiligingen en is dus niet geschikt als voorbeeldbestand. Dus obv het het bestand in #1.

Sub VenA()
  ar = Sheets("BESTELLIJST").Cells(1).CurrentRegion.Offset(1).Columns(1).SpecialCells(2).Offset(1).SpecialCells(2).Resize(, 6)
  Sheets("Besteloverzicht").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(ar), 6) = ar
  ar1 = Sheets("DB_PRODUCTEN").Cells(1).CurrentRegion.Resize(, 5)
  For j = 1 To UBound(ar)
    For jj = 1 To UBound(ar1)
      If ar(j, 1) = ar1(jj, 1) Then ar1(jj, 5) = ar1(jj, 5) + ar(j, 4)
    Next jj
  Next j
  Sheets("DB_PRODUCTEN").Cells(1).CurrentRegion.Resize(, 5) = ar1
End Sub

 

[snb]

of ?

Private Sub Bestellen_Click()
  ListObjects(1).DataBodyRange.Copy Blad3.Cells(Rows.Count, 1).End(xlUp).Offset(1)

  For Each it In ListObjects(1).DataBodyRange.Columns(4).Cells
     With Blad2.Columns(1).Find(it.Offset(, -3))
        .Offset(, 4) = .Offset(, 4) - it
    End With
  Next
End Sub

 

[SjonR]

@ VenA,

ik vierde op dat moment mijn 1 jarig lidmaatschap

 

[VenA]

Alsnog gefeliciteerd en dat we nog veel verjaardagen met met je mogen vieren:d