Excel VBA DB copy problem

M

martinus1988

New Member
Joined
Aug 13, 2015
Messages
15
For an order system I have a problem.

When we order parts we push button. All the parts are copied to the DB sheet.
The problem is as follows:
The macro is fixed on 25 lines (part lines). This means that the macro always copies the 25 lines (even if there are only 2 parts to be ordered from that supplier).
The macro runs very slow.
When you run another order, the macro start copy at line 26 (it should start at the first empty A column).

Can someone please help me make this macro better and faster.
Thank you very much!!!
Excel Help Forum
 

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.
Sort by date Sort by votes
HockeyDiablo said:
It would be extremely helpful if you posted that macro code.
Click to expand...
Please check link below original post to download excel.

Code: 
Option Explicit
Sub Purchase_Order()

Dim DB As Worksheet, SH As Worksheet
Dim 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 = ThisWorkbook.Worksheets("Per leverancier bestellen")
Set DB = ThisWorkbook.Worksheets("DB Bestelling Purchase Order")
With DB
    TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With
SourceArr = Array("D3", "I2", "E1", "B5", "C5", "D5", "E5", "F5", "G5", "H5", "I5")
DestArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K")

'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

Set SH = ThisWorkbook.Worksheets("Per leverancier bestellen")
Set DB = ThisWorkbook.Worksheets("DB Bestelling Purchase Order")
With DB
    TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With

SourceArr = Array("D3", "I2", "E1", "B6", "C6", "D6", "E6", "F6", "G6", "H6", "I6")
DestArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K")

'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
Set SH = ThisWorkbook.Worksheets("Per leverancier bestellen")
Set DB = ThisWorkbook.Worksheets("DB Bestelling Purchase Order")
With DB
    TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With

SourceArr = Array("D3", "I2", "E1", "B7", "C7", "D7", "E7", "F7", "G7", "H7", "I7")
DestArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K")

'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
Set SH = ThisWorkbook.Worksheets("Per leverancier bestellen")
Set DB = ThisWorkbook.Worksheets("DB Bestelling Purchase Order")
With DB
    TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With

SourceArr = Array("D3", "I2", "E1", "B8", "C8", "D8", "E8", "F8", "G8", "H8", "I8")
DestArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K")

'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
Set SH = ThisWorkbook.Worksheets("Per leverancier bestellen")
Set DB = ThisWorkbook.Worksheets("DB Bestelling Purchase Order")
With DB
    TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With

SourceArr = Array("D3", "I2", "E1", "B9", "C9", "D9", "E9", "F9", "G9", "H9", "I9")
DestArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K")

'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
Set SH = ThisWorkbook.Worksheets("Per leverancier bestellen")
Set DB = ThisWorkbook.Worksheets("DB Bestelling Purchase Order")
With DB
    TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With

SourceArr = Array("D3", "I2", "E1", "B10", "C10", "D10", "E10", "F10", "G10", "H10", "I10")
DestArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K")

'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
Set SH = ThisWorkbook.Worksheets("Per leverancier bestellen")
Set DB = ThisWorkbook.Worksheets("DB Bestelling Purchase Order")
With DB
    TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With

SourceArr = Array("D3", "I2", "E1", "B11", "C11", "D11", "E11", "F11", "G11", "H11", "I11")
DestArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K")

'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
Set SH = ThisWorkbook.Worksheets("Per leverancier bestellen")
Set DB = ThisWorkbook.Worksheets("DB Bestelling Purchase Order")
With DB
    TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With

SourceArr = Array("D3", "I2", "E1", "B12", "C12", "D12", "E12", "F12", "G12", "H12", "I12")
DestArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K")

'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
Set SH = ThisWorkbook.Worksheets("Per leverancier bestellen")
Set DB = ThisWorkbook.Worksheets("DB Bestelling Purchase Order")
With DB
    TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With

SourceArr = Array("D3", "I2", "E1", "B13", "C13", "D13", "E13", "F13", "G13", "H13", "I13")
DestArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K")

'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
Set SH = ThisWorkbook.Worksheets("Per leverancier bestellen")
Set DB = ThisWorkbook.Worksheets("DB Bestelling Purchase Order")
With DB
    TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With

SourceArr = Array("D3", "I2", "E1", "B14", "C14", "D14", "E14", "F14", "G14", "H14", "I14")
DestArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K")

'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
Set SH = ThisWorkbook.Worksheets("Per leverancier bestellen")
Set DB = ThisWorkbook.Worksheets("DB Bestelling Purchase Order")
With DB
    TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With

SourceArr = Array("D3", "I2", "E1", "B15", "C15", "D15", "E15", "F15", "G15", "H15", "I15")
DestArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K")

'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
Set SH = ThisWorkbook.Worksheets("Per leverancier bestellen")
Set DB = ThisWorkbook.Worksheets("DB Bestelling Purchase Order")
With DB
    TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With

SourceArr = Array("D3", "I2", "E1", "B16", "C16", "D16", "E16", "F16", "G16", "H16", "I16")
DestArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K")

'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
Set SH = ThisWorkbook.Worksheets("Per leverancier bestellen")
Set DB = ThisWorkbook.Worksheets("DB Bestelling Purchase Order")
With DB
    TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With

SourceArr = Array("D3", "I2", "E1", "B17", "C17", "D17", "E17", "F17", "G17", "H17", "I17")
DestArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K")

'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
Set SH = ThisWorkbook.Worksheets("Per leverancier bestellen")
Set DB = ThisWorkbook.Worksheets("DB Bestelling Purchase Order")
With DB
    TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With

SourceArr = Array("D3", "I2", "E1", "B18", "C18", "D18", "E18", "F18", "G18", "H18", "I18")
DestArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K")

'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
Set SH = ThisWorkbook.Worksheets("Per leverancier bestellen")
Set DB = ThisWorkbook.Worksheets("DB Bestelling Purchase Order")
With DB
    TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With

SourceArr = Array("D3", "I2", "E1", "B19", "C19", "D19", "E19", "F19", "G19", "H19", "I19")
DestArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K")

'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
Set SH = ThisWorkbook.Worksheets("Per leverancier bestellen")
Set DB = ThisWorkbook.Worksheets("DB Bestelling Purchase Order")
With DB
    TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With

SourceArr = Array("D3", "I2", "E1", "B20", "C20", "D20", "E20", "F20", "G20", "H20", "I20")
DestArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K")

'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
Set SH = ThisWorkbook.Worksheets("Per leverancier bestellen")
Set DB = ThisWorkbook.Worksheets("DB Bestelling Purchase Order")
With DB
    TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With

SourceArr = Array("D3", "I2", "E1", "B21", "C21", "D21", "E21", "F21", "G21", "H21", "I21")
DestArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K")

'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
Set SH = ThisWorkbook.Worksheets("Per leverancier bestellen")
Set DB = ThisWorkbook.Worksheets("DB Bestelling Purchase Order")
With DB
    TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With

SourceArr = Array("D3", "I2", "E1", "B22", "C22", "D22", "E22", "F22", "G22", "H22", "I22")
DestArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K")

'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
Set SH = ThisWorkbook.Worksheets("Per leverancier bestellen")
Set DB = ThisWorkbook.Worksheets("DB Bestelling Purchase Order")
With DB
    TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With

SourceArr = Array("D3", "I2", "E1", "B23", "C23", "D23", "E23", "F23", "G23", "H23", "I23")
DestArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K")

'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
Set SH = ThisWorkbook.Worksheets("Per leverancier bestellen")
Set DB = ThisWorkbook.Worksheets("DB Bestelling Purchase Order")
With DB
    TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With

SourceArr = Array("D3", "I2", "E1", "B24", "C24", "D24", "E24", "F24", "G24", "H24", "I24")
DestArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K")

'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
Set SH = ThisWorkbook.Worksheets("Per leverancier bestellen")
Set DB = ThisWorkbook.Worksheets("DB Bestelling Purchase Order")
With DB
    TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With

SourceArr = Array("D3", "I2", "E1", "B25", "C25", "D25", "E25", "F25", "G25", "H25", "I25")
DestArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K")

'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
Set SH = ThisWorkbook.Worksheets("Per leverancier bestellen")
Set DB = ThisWorkbook.Worksheets("DB Bestelling Purchase Order")
With DB
    TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With

SourceArr = Array("D3", "I2", "E1", "B26", "C26", "D26", "E26", "F26", "G26", "H26", "I26")
DestArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K")

'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
Set SH = ThisWorkbook.Worksheets("Per leverancier bestellen")
Set DB = ThisWorkbook.Worksheets("DB Bestelling Purchase Order")
With DB
    TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With

SourceArr = Array("D3", "I2", "E1", "B27", "C27", "D27", "E27", "F27", "G27", "H27", "I27")
DestArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K")

'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
Set SH = ThisWorkbook.Worksheets("Per leverancier bestellen")
Set DB = ThisWorkbook.Worksheets("DB Bestelling Purchase Order")
With DB
    TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With

SourceArr = Array("D3", "I2", "E1", "B28", "C28", "D28", "E28", "F28", "G28", "H28", "I28")
DestArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K")

'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
Set SH = ThisWorkbook.Worksheets("Per leverancier bestellen")
Set DB = ThisWorkbook.Worksheets("DB Bestelling Purchase Order")
With DB
    TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With

SourceArr = Array("D3", "I2", "E1", "B29", "C29", "D29", "E29", "F29", "G29", "H29", "I29")
DestArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K")


'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



End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Solved
Using VBA to select a color coded cell
2
Replies
11
Views
467
Alex Blakenburg
A
K
  • Question
VBA macro sometimes requires running twice to fully complete
Replies
6
Views
125
knittelmail
K
Q
  • Solved
Copying from one Worksheet to another repeatedly.
Replies
4
Views
201
qh017
Q
C
  • Question
Script crashes - sometimes
Replies
7
Views
356
cowboysnut
C
tsroque
  • Question
Excel VBA to Copy Range, Open Gmail and Paste in Body
Replies
0
Views
138
tsroque
tsroque

Forum statistics

Threads
1,217,396
Messages
6,136,378
Members
450,006
Latest member
DaveLlew

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top