将大型数据集转换为2D数组，然后根据条件转换为2D倍数

Question

决不是，我是一个有经验的程序员，但确实需要以下任务的帮助。

我有一个中等大小的大型数据集，它按固定no的行数增长。列(81)，用于以后的分配(没有枢轴TB1和/或公式)。

下面是到目前为止能够实现的代码:按月声明从数据集填充的所有数组，创建一维数组以添加所有列，然后粘贴到月份wksht中。

并坚持粘贴到JAN之后

提前感谢

 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

Answer 1

代码中可能存在多个问题。一个显然是RG02 = arrFEB，我想应该是arrFEB=RG02。但为什么要这么夸张呢？为什么不使用下面这样简单的东西呢？

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

希望能对大家有所帮助。