Option Explicit
Sub PurchaseTransfer()
Dim vIn As Variant, vWH As Variant, vAP As Variant, vCost As Variant
Dim lRi As Long, lCi As Long, lRw As Long, lRa As Long, lItems As Long, UB As Long
'get entry data into arrays for fast processing
vIn = Sheets("Purchase").Range("A3").CurrentRegion
UB = UBound(vIn, 1)
vCost = Sheets("Purchase").Range("A:A").Find("Subtotal").Offset(0, 4).Resize(3, 1)
lItems = UB - 3
'resize output arrays
ReDim vWH(1 To lItems, 1 To 9)
ReDim vAP(1 To 1, 1 To 6)
'fill out warehouse array
vWH(1, 1) = vIn(1, 5) 'Doc No
vWH(1, 2) = vIn(2, 5) 'Date
vWH(1, 8) = vCost(2, 1) 'Cartage <<<<<< Put a ' in front of this line to disable Cartage being printed on the Warehouse sheet
vWH(1, 9) = vCost(3, 1) 'Grand Tot <<<<<< Put a ' in front of this line to disable Grand Total being printed on the Warehouse sheet
For lRi = 4 To UB
lRw = lRw + 1
For lCi = 1 To 5
vWH(lRw, lCi + 2) = vIn(lRi, lCi)
Next lCi
Next lRi
'fill out Accounts Payable array
vAP(1, 1) = vIn(1, 5) 'Doc No
vAP(1, 2) = vIn(2, 5) 'Date
vAP(1, 3) = vIn(4, 1) 'Suppl No
vAP(1, 4) = -vCost(1, 1) 'Subtot
vAP(1, 5) = -vCost(2, 1) 'Cart
vAP(1, 6) = -vCost(3, 1) 'Grndtot
'Write arrays to sheets
With Sheets("Data Warehouse")
lRw = .Range("A1").CurrentRegion.Rows.Count
.Range("A" & lRw + 1).Resize(lItems, 9) = vWH
End With
With Sheets("AP")
lRa = .Range("A1").CurrentRegion.Rows.Count
.Range("A" & lRa + 1).Resize(1, 6) = vAP
End With
'clear input data
With Sheets("Purchase")
.Range("A4").Resize(lItems, 5).ClearContents
.Range("E1:E2").ClearContents
End With
End Sub
