Excel VBA: Copy naar Database

[martinus1988]

Hoi,

Als ik een bestelling wil plaatsen is een onderdeel van de macro dat hij de bestelling kopieerd naar BLAD "DB Order". Dit gaat opzich prima alleen het betreft vaak meer dan 1 regel en daar gaat het mis.
Hoe krijg ik de VBA zo dat hij alle regels pakt met de daarbij behorende celwaardes.

Alvast bedankt!!!
Martijn
Bekijk bijlage DB problem.xlsm

 

[OctaFish]

Als je vaste waarden in een array stopt, dan blijf je nog wel even dezelfde rij kopieëren. Het kan heel veel slimmer, maar om in je eigen macro te blijven heb ik een kleine aanpassing gemaakt waardoor het wel werkt.

Sub Purchase_Order()
Dim DB As Worksheet, SH As Worksheet, Cel As Range
Dim SourceRow As Long, TargetRow As Long, Index As Long
Dim SourceArr As Variant, DestArr As Variant
Dim Source As Range, Dest As Range

'set references up-front
Set SH = Worksheets("Order")
Set DB = Worksheets("DB Order")
Set Cel = ActiveCell
SourceRow = Cel.Row
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    With DB
        TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
    End With
    SourceArr = Array("B" & SourceRow, "D3", "E1", "B" & SourceRow, "C" & SourceRow, "D" & SourceRow, "E" & SourceRow, "F" & SourceRow, "G" & SourceRow, "G2")
    DestArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J")

    'loop through the source array, copying cell values to DB sheet
    For Index = LBound(SourceArr) To UBound(SourceArr)
        Set Source = SH.Range(SourceArr(Index))
        Set Dest = DB.Range(DestArr(Index) & TargetRow)
        Source.Copy
        Dest.PasteSpecial (xlPasteValues)
    Next Index
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub

 

[martinus1988]

Excel VBA DB copy probleem

Hey Octafish,

Ik krijg het niet werkend. Ik heb het bestand opnieuw als bijlage toegevoegd. Kunt u misschien nog 1 keer helpen?

Bekijk bijlage DB problem.xlsm

 

[OctaFish]

Ik zal het nog makkelijker maken: hier de versie die ik zelf in elkaar heb geflanst.

 

[martinus1988]

Ja maar dit werkt toch ook niet? Waar zijn de producten met prijzen dan?
Deze moeten per regel worden weergegeven zoals voorbeeld in de DB order

 

[martinus1988]

Elke regel moet worden toegevoegd:
NTD 50 .. ... . .. . .
NTD 51 .. ... . .. . .
NTD 52 .. ... . .. . .
NTD 53 .. ... . .. . .

 

[OctaFish]

Ik heb je eigen systeem overgenomen waarbij je een rij wilt kopieren. En dat werkt. Wil je wat anders, dan zou ik eerst een betere opzet maken, want ik kan hier eerlijk gezegd ook niet zoveel chocola van maken.

 

[martinus1988]

Update van probleem

Laten we dan maar even opnieuw beginnen.

Werkwijze:
Voor het bestellen van producten bij leveranciers gebruiken wij Blad Webshopbestellingen bevestigen. Hier vullen wij de orderbevestiging in. Deze wordt vervolgens bevestigd door op de knop te drukken.
De macro schrijft alles weg naar tabblad DB.

Probleem:
Het is extreem langzaam
Hij schrijft 25 regels weg, ongeacht of er data in de regel staat (stel er staan 10 parts in, schrijft de macro alsnog 25 regels weg)
Als je een volgende bestelling wilt bevestigen begint de eerste regel na de 25ste regel. (Als kolom A+Regelnummer leeg is dan daar beginnen.)

Wie kan mij helpen met een verbetering.
Zie bijlage
Bekijk bijlage DB problem2.xlsm

 

[VenA]

Gebruik bij voorkeur geen samengevoegde cellen. Kolom A verbergen lijkt ook niet echt nodig. De formules in voormalig kolom B heb ik eruit gehaald.

Sub VenA()
Dim ar, ar1, j As Long
With Sheets("Webshop bestellingen bevestigen")
    ar = .Cells(7, 1).CurrentRegion
    ReDim ar1(1 To UBound(ar) - 1, 1 To 11)
    For j = 2 To UBound(ar)
        ar1(j - 1, 1) = ar(j, 1)
        ar1(j - 1, 2) = ar(j, 4)
        ar1(j - 1, 3) = ar(j, 5)
        ar1(j - 1, 4) = ar(j, 6)
        ar1(j - 1, 5) = ar(j, 7)
        ar1(j - 1, 6) = ar(j, 3)
        ar1(j - 1, 7) = .[C2]
        ar1(j - 1, 8) = .[C3]
        ar1(j - 1, 9) = .[C4]
        ar1(j - 1, 10) = .[C4]
        ar1(j - 1, 11) = Date
    Next j
End With
Sheets("DB Bestelling bevestigen").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(ar1), UBound(ar1, 2)) = ar1
End Sub