Manipulating Columns VBA - excel

Question

I have got below coding for my huge data set VBA, I wish to manipulate columns according to my range criteria, Please help.
Dim Ary As Variant, Nary As Variant
Dim r As Long, Rw As Long
With Sheets("Sheet1")
Ary = .Range("A2:B" & .Range("A" & Rows.Count).End(xlUp).Row).Value2
End With
ReDim Nary(1 To UBound(Ary), 1 To 1)
With CreateObject("scripting.dictionary")
For r = 1 To UBound(Ary)
If Not .Exists(Ary(r, 1)) Then
.Add Ary(r, 1), r
Nary(r, 1) = Ary(r, 2)
Else
Rw = .Item(Ary(r, 1))
Nary(Rw, 1) = Nary(Rw, 1) + Ary(r, 2)
End If
Next r
End With
Sheets("sheet1").Range("C2").Resize(UBound(Nary)).Value = Nary
Sheets("sheet1").Range("C2").Resize(UBound(Nary)).Value = Nary
I want to columns re-arrange as per below criteria,
ColumnA = ColumnD (4)
ColumnB = ColumnN (14)
ColumnC - ColumnO (15)
Please re-codes above Ubound & Lbound coding as per above criteria, As I am not far used to with arrays
functions codes.
Above coding are working fine I just want to manipulate columns.
Thankyou

Answer 1

Get First Sums
The following sums up the values in a column for each unique value in another column and displays the result in a third column in the rows of the first occurrence of each unique value.
Option Explicit
Function getFirstSums( _
ws As Worksheet, _
ByVal LookUpColumn As Variant, _
ByVal ValuesColumn As Variant, _
Optional ByVal FirstRow As Long = 1) _
As Variant
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, LookUpColumn).End(xlUp).Row
Dim rng As Range
Set rng = ws.Cells(FirstRow, LookUpColumn).Resize(LastRow - FirstRow + 1)
Dim Lookup As Variant: Lookup = rng.Value
Dim SumUp As Variant
SumUp = rng.Offset(, ws.Columns(ValuesColumn).Column _
- ws.Columns(LookUpColumn).Column).Value
Dim rCount As Long: rCount = UBound(Lookup)
Dim Result As Variant: ReDim Result(1 To rCount, 1 To 1)
Dim r As Long, rw As Long
With CreateObject("Scripting.Dictionary")
For r = 1 To rCount
If Not .Exists(Lookup(r, 1)) Then
.Add Lookup(r, 1), r
Result(r, 1) = SumUp(r, 1)
Else
rw = .Item(Lookup(r, 1))
Result(rw, 1) = Result(rw, 1) + SumUp(r, 1)
End If
Next r
End With
getFirstSums = Result
End Function
Sub TESTgetFirstSums()
Const wsName As String = "Sheet1"
Const LookUpColumn As Variant = "D"
Const ValuesColumn As Variant = "N"
Const ResultColumn As Variant = "O"
Const FirstRow As Long = 2
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim ary As Variant
ary = getFirstSums(ws, LookUpColumn, ValuesColumn, FirstRow)
ws.Range(ResultColumn & FirstRow).Resize(UBound(ary)).Value = ary
End Sub
Sub TESTgetFirstSumsSimple()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim ary As Variant
ary = getFirstSums(ws, 4, 14, 2)
ws.Cells(2, 15).Resize(UBound(ary)).Value = ary
End Sub
EDIT:
Or you might rather write it as a sub procedure:
Sub writeFirstSums( _
ws As Worksheet, _
ByVal LookUpColumn As Variant, _
ByVal ValuesColumn As Variant, _
ByVal ResultColumn As Variant, _
Optional ByVal FirstRow As Long = 1)
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, LookUpColumn).End(xlUp).Row
Dim rng As Range
Set rng = ws.Cells(FirstRow, LookUpColumn).Resize(LastRow - FirstRow + 1)
Dim Lookup As Variant: Lookup = rng.Value
Dim SumUp As Variant
SumUp = rng.Offset(, ws.Columns(ValuesColumn).Column _
- ws.Columns(LookUpColumn).Column).Value
Dim rCount As Long: rCount = UBound(Lookup)
Dim Result As Variant: ReDim Result(1 To rCount, 1 To 1)
Dim r As Long, rw As Long
With CreateObject("Scripting.Dictionary")
For r = 1 To rCount
If Not .Exists(Lookup(r, 1)) Then
.Add Lookup(r, 1), r
Result(r, 1) = SumUp(r, 1)
Else
rw = .Item(Lookup(r, 1))
Result(rw, 1) = Result(rw, 1) + SumUp(r, 1)
End If
Next r
End With
ws.Cells(FirstRow, ResultColumn).Resize(UBound(Result)) = Result
End Sub
Sub TESTwriteFirstSumsSimple()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
writeFirstSums ws, 4, 14, 15, 2
End Sub