Pfthb

By no means, I am an experienced coder, but do need assistance with the following task.

I have a medium size to a large dataset that grows by rows with a fixed no. columns (81), for later distribution (no pivot tbl and/or formulas).

The below is the code that has so far able to achieve:
Declare all arrays by month populated from the dataset, create 1D array to add all columns and later paste transposed into the MONTH wksht.

and stuck on pasting past JAN

Thanks in advance

 Sub RangeSize2()

 Application.ScreenUpdating = False

 Dim ws1 As Worksheet
 Dim ws3 As Worksheet

 Dim FinalSelection As Range, LRs3, LCs3 As Long, X As Integer
 Dim Rx1, Rx2, Rx3, Rx4, Rx5, Rx6, Rx7, Rx8, Rx9, Rx10, Rx11, Rx12, Ry1, Ry2, Ry3, Ry4, Ry5, Ry6, Ry7, Ry8, Ry9, Ry10, Ry11, Ry12 As Long

Dim monthnames() As Variant
monthnames = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")


Dim arrJAN(), arrFEB(), arrMAR() As Variant
Dim RG01, RG02, RG03, RG04, RG05, RG06, RG07, RG08, RG09, RG10, RG11, RG12 As Range
Dim c As Range, v As String

Set ws1 = ThisWorkbook.Worksheets("MONTH")
Set ws3 = ThisWorkbook.Worksheets("DATA")

LRs3 = Sheets("DATA").Cells(Rows.count, "A").End(xlUp).Row
LCs3 = Sheets("DATA").Cells(3, Columns.count).End(xlToLeft).Column

Cells(4, 1).Select
Sheets("DATA").Select

For X = 1 To 12

 For Each c In Intersect(ActiveSheet.UsedRange, Range("B:B"))
 If c.Value = monthnames(X) Then
 v = c.Value '= v
 If FinalSelection Is Nothing Then
 Set FinalSelection = Range(Cells(c.Row, 1), Cells(c.Row, LCs3))
 Else
 Set FinalSelection = Union(FinalSelection, Range(Cells(c.Row, 1), Cells(c.Row, LCs3)))
 End If
 End If
 Next c
 ''msgBox v

 If Not FinalSelection Is Nothing Then FinalSelection.Select


 If X = 1 Then
 Ry1 = FinalSelection.Rows.count + FinalSelection.Row - 1
 Rx1 = FinalSelection.Row
 'msgBox v & " - " & Rx1 & " - " & Ry1
 End If

 If X = 2 Then
 Ry2 = FinalSelection.Rows.count + FinalSelection.Row - 1
 Rx2 = Ry1 + 1
 'msgBox v & " - " & Rx2 & " - " & Ry2
 End If

 If X = 3 Then
 Ry3 = FinalSelection.Rows.count + FinalSelection.Row - 1
 Rx3 = Ry2 + 1
 'msgBox v & " - " & Rx3 & " - " & Ry3
 End If

 If X = 4 Then
 Ry4 = FinalSelection.Rows.count + FinalSelection.Row - 1
 Rx4 = Ry3 + 1
 'msgBox v & " - " & Rx4 & " - " & Ry4
 End If

 If X = 5 Then
 Ry5 = FinalSelection.Rows.count + FinalSelection.Row - 1
 Rx5 = Ry4 + 1
 'msgBox v & " - " & Rx5 & " - " & Ry5
 End If

 If X = 6 Then
 Ry6 = FinalSelection.Rows.count + FinalSelection.Row - 1
 Rx6 = Ry5 + 1
 'msgBox v & " - " & Rx6 & " - " & Ry6
 End If

 If X = 7 Then
 Ry7 = FinalSelection.Rows.count + FinalSelection.Row - 1
 Rx7 = Ry6 + 1
 'msgBox v & " - " & Rx7 & " - " & Ry7
 End If

 If X = 8 Then
 Ry8 = FinalSelection.Rows.count + FinalSelection.Row - 1
 Rx8 = Ry7 + 1
 'msgBox v & " - " & Rx8 & " - " & Ry8
 End If

 If X = 9 Then
 Ry9 = FinalSelection.Rows.count + FinalSelection.Row - 1
 Rx9 = Ry8 + 1
 'msgBox v & " - " & Rx9 & " - " & Ry9
 End If

 If X = 10 Then
 Ry10 = FinalSelection.Rows.count + FinalSelection.Row - 1
 Rx10 = Ry9 + 1
 'msgBox v & " - " & Rx10 & " - " & Ry10
 End If

 If X = 11 Then
 Ry11 = FinalSelection.Rows.count + FinalSelection.Row - 1
 Rx11 = Ry10 + 1
 'msgBox v & " - " & Rx11 & " - " & Ry11
 End If

 If X = 12 Then

 Ry12 = FinalSelection.Rows.count + FinalSelection.Row - 1
 Rx12 = Ry11 + 1
 'msgBox v & " - " & Rx12 & " - " & Ry12
 End If

 Next X

 'RG01, RG02, RG03, RG04, RG05, RG06, RG07, RG08, RG09, RG10, RG11, RG12

 '''''''''''''''''''''''''''''''looping & pasting each range

Dim RR As Long, CC As Long
Dim TotalCol As Double

'JAN''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

 ws3.Activate
 RG01 = ws3.Range(Cells(Rx1, 1), Cells(Ry1, LCs3)).Value2
 arrJAN = RG01
 Dim JANTotal() As Variant
 ReDim JANTotal(1 To LCs3)

 TotalCol = 0

 For CC = 1 To LCs3
 For RR = 1 To UBound(arrJAN, 1)
 On Error Resume Next
 TotalCol = TotalCol + arrJAN(RR, CC)
 JANTotal(CC) = TotalCol
 Next RR
 TotalCol = 0
 Next CC

ws1.Activate
 'paste to MONT SHt
 ws1.Range(Cells(4, 3), Cells(LCs3 + 3, 3)) = Application.Transpose(JANTotal)
 ' Erase arrJAN
 ' Erase JANTotal
RR = 0
CC = 0
 'FEB''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 ws3.Activate
 RG02 = ws3.Range(Cells(Rx2, 1), Cells(Ry2, LCs3)).Value2
 RG02 = arrFEB
 Dim FEBTotal() As Variant
 ReDim FEBTotal(1 To LCs3)

 TotalCol = 0

 For CC = 1 To LCs3
 For RR = 1 To UBound(arrFEB, 1)
 On Error Resume Next
 TotalCol = TotalCol + arrFEB(RR, CC)
 FEBTotal(CC) = TotalCol
 Next RR
 TotalCol = 0
 Next CC
ws1.Activate
 'paste to MONT SHt
 ws1.Range(Cells(4, 4), Cells(LCs3 + 3, 4)) = Application.Transpose(FEBTotal)
 ' Erase arrFEB

Application.ScreenUpdating = True



End Sub

There may be multiple issues in the code. One is obviously RG02 = arrFEB, think it would be arrFEB=RG02. But why go for such an overkill. Why not use something simple as below

Option Base 1
Sub test()
Dim ws1 As Worksheet
Dim ws3 As Worksheet

Dim Rng, smRng, CrtRng As Range, LRs3, LCs3, Cl As Long, M As Integer, V As String, Sm As Double
Dim monthnames() As Variant
monthnames = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")

Set ws1 = ThisWorkbook.Worksheets("MONTH")
Set ws3 = ThisWorkbook.Worksheets("DATA")

LRs3 = ws3.Cells(Rows.Count, "A").End(xlUp).Row
LCs3 = ws3.Cells(3, Columns.Count).End(xlToLeft).Column
Set Rng = ws3.Range(ws3.Cells(1, 1), ws3.Cells(LRs3, LCs3))
Set CrtRng = ws3.Range(ws3.Cells(1, 2), ws3.Cells(LRs3, 2))
'MsgBox Rng.Address

For M = 1 To 12
V = monthnames(M)
 For Cl = 1 To LCs3
 Set smRng = ws3.Range(ws3.Cells(1, Cl), ws3.Cells(LRs3, Cl))
 If Cl <> 2 Then
 Sm = Application.WorksheetFunction.SumIf(CrtRng, V, smRng)
 'ws3.Cells(LRs3 + 2 + M, Cl).Value = Sm ' for checking below data range by applying data filter
 ws1.Cells(3 + Cl, 2 + M).Value = Sm
 Else
 'ws3.Cells(LRs3 + 2 + M, Cl).Value = V ' for checking below data range by applying data filter
 ws1.Cells(3 + Cl, 2 + M).Value = V
 End If
 Next Cl
Next M

End Sub

Hope it will be useful.