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
Dim rST As Range
'get entry data into arrays for fast processing
Set rST = Sheets("Purchase").Range("A:A").Find("Subtotal")
vCost = rST.Offset(0, 4).Resize(3, 1)
lRi = Sheets("Purchase").Range("A3").CurrentRegion.Rows.Count
lRi = Application.WorksheetFunction.Min(lRi, rST.Row - 1)
With Sheets("Purchase").Range("A1")
vIn = .Resize(lRi, 5).Value
End With
UB = UBound(vIn, 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
vWH(1, 9) = vCost(3, 1) 'Grand Tot
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
.Range("E11").ClearContents
End With
End Sub
