Option Explicit
Sub TransferSales()
Dim wsInp As Worksheet, wsOutp As Worksheet
Dim lRIn As Long, lROut As Long, lC As Long, lR1st As Long, lUB1 As Long, lUB2 As Long
Dim vIn As Variant, vOut As Variant
Dim bNewFlag As Boolean
Const sInputName As String = "Sheet2" ' <<< Modify name of input data sheet if required
Const sOutputName As String = "Sheet1" ' <<< Modify name of output sheet if required
bNewFlag = True ' <<< True will delete existing output and recreate, False will add to bottom of list
On Error Resume Next
Set wsInp = Sheets(sInputName)
Set wsOutp = Sheets(sOutputName)
On Error GoTo 0
' Check if sheets exist
If wsInp Is Nothing Then
MsgBox "No input sheet " & sInputName & " found!", vbCritical
Exit Sub
End If
If wsOutp Is Nothing Then
If bNewFlag Then 'if asked to create new one anyway than create it
Set wsOutp = Sheets.Add
wsOutp.Name = sOutputName
Else
MsgBox "No output sheet " & sOutputName & " found!", vbCritical
Exit Sub
End If
End If
'Copy input sheet into an array to speed up processing (reading from each cell takes a lot of time)
'the array can be used as a virtual sheet
vIn = wsInp.Range("A1").CurrentRegion.Value
' Get the size of the array
lUB1 = UBound(vIn, 1)
lUB2 = UBound(vIn, 2)
'Create the Output array, This will have twice as many rows as the input array and 13 columns (A-M)
ReDim vOut(1 To 2 * lUB1, 1 To 13)
'Create titlerow if necessary
If bNewFlag Then ' ------ Create new output, don't add to list
vOut(1, 1) = "TV. No."
vOut(1, 2) = "Transferee"
vOut(1, 3) = "Date"
vOut(1, 4) = "Land Extent"
vOut(2, 4) = "m²"
vOut(2, 5) = "perche"
vOut(1, 7) = "Declared value" & vbCrLf & "(Rs)"
vOut(1, 8) = "Analysis"
vOut(2, 8) = "Rs/m²"
vOut(2, 9) = "Rs/P"
vOut(1, 10) = "Region"
vOut(1, 11) = "District"
vOut(1, 12) = "Location"
vOut(1, 13) = "Remarks"
'on output sheet set title row formatting
With wsOutp
If .Range("A1") <> "" Then 'if existing information, remove
.Range("A1").CurrentRegion.EntireRow.Delete
End If
FormatTitle wsOutp
FormatOutp .Range(.Cells(3, 1), .Cells(lUB1 * 2, 13)) 'format the output area
End With
lR1st = 1 'first output row
lROut = 3
Else ' -------- Add output to bottom of existing data
With wsOutp
lR1st = .Range("A1").CurrentRegion.Rows + 1 ''first output row
lROut = 1
FormatOutp .Range(.Cells(lR1st, 1), .Cells(lUB1 * 2 + lR1st, 13)) 'format the output area
End With
End If
' Now create output
'(1) From Sheet2 range A2 :A To Sheet1 range A3:A
'(2) From Sheet2 range C2:C To Sheet1 range B3:B
'(3) From Sheet2 range D2:D To Sheet1 range C3:C
'(4) From Sheet2 range E2:E To Sheet1 range K3:k
'(4) From Sheet2 range F2:F To Sheet1 range J3:J
'(5) From Sheet2 range K2:k To Sheet1 range D3:D
'(6) In Sheet1 range E3:E to use the formula range D3:D divided by 42.2081
'(7) In Sheet1 rangel H3:H to use the formula range G3:G divided by range D3:D
'(8) In Sheet1 range I3:I TO use the formula range G3:G divided by range E3:E
For lRIn = 2 To lUB1
vOut(lROut, 1) = vIn(lRIn, 1) 'copy column A
vOut(lROut, 2) = vIn(lRIn, 3) 'copy column C>B
vOut(lROut, 3) = vIn(lRIn, 4) 'copy column D>C
vOut(lROut, 11) = vIn(lRIn, 5) 'copy column E>K
vOut(lROut, 10) = vIn(lRIn, 6) 'copy column F>J
vOut(lROut, 7) = vIn(lRIn, 8) 'copy column H>G
vOut(lROut, 4) = vIn(lRIn, 11) 'copy column A
vOut(lROut, 5) = vOut(lROut, 4) / 42.2081 'Calc col E
vOut(lROut, 8) = vOut(lROut, 7) / vOut(lROut, 4) 'Calc H
vOut(lROut, 9) = vOut(lROut, 7) / vOut(lROut, 5) 'Calc I
vOut(lROut, 6) = "Land"
vOut(lROut + 1, 6) = "Building"
'Now increment output row by 2
lROut = lROut + 2
Next lRIn
'Then output the array to the output sheet
With wsOutp
.Cells(lR1st, 1).Resize(lUB1 * 2, 13).Value = vOut
End With
End Sub
Sub FormatTitle(wsOut As Worksheet)
With wsOut
.Range("A1:A2").Merge
.Range("B1:B2").Merge
.Range("C1:C2").Merge
.Range("D1:E1").Merge
.Range("G1:G2").Merge
.Range("H1:I1").Merge
.Range("J1:J2").Merge
.Range("K1:K2").Merge
.Range("L1:L2").Merge
.Range("M1:M2").Merge
With .Range("A1:M2")
With .Interior
.Pattern = xlSolid
.Color = 65535
End With
With .Borders(xlEdgeLeft)
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.Weight = xlThin
End With
With .Borders(xlInsideHorizontal)
.Weight = xlThin
End With
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
End Sub
Sub FormatOutp(rOut As Range)
Dim lR As Long
Dim rF As Range
With rOut.Parent ' the output sheet
For lR = rOut.Row To rOut.Row + rOut.Rows.Count Step 2
.Range("A" & lR & ":A" & lR + 1).Merge
.Range("B" & lR & ":B" & lR + 1).Merge
.Range("C" & lR & ":C" & lR + 1).Merge
.Range("J" & lR & ":J" & lR + 1).Merge
.Range("K" & lR & ":K" & lR + 1).Merge
Next lR
End With
With rOut
With .Borders(xlEdgeLeft)
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.Weight = xlThin
End With
With .Borders(xlInsideHorizontal)
.Weight = xlThin
End With
End With
End Sub
