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
 
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

zookeepertx
  • Question Question
Formatting problems
Replies
2
Views
349
zookeepertx
zookeepertx
Z
  • Question Question
VBA Complex Organizational Loop
Replies
1
Views
120
HighAndWilder
H
M
  • Question Question
Macro/Automating Edits and Calculations for Large Report (40K rows)
Replies
6
Views
244
kevin9999
K
M
  • Solved
VBA script help for copying same data into different tabs
2
Replies
15
Views
505
mlance617
M
A
  • Question Question
Purchase Order macros
Replies
5
Views
609
AndyB86
A

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