我绝对不是一名经验丰富的编码员，但是在以下任务上确实需要帮助。
我有一个中等大小的大型数据集，该数据集按固定编号的行增长。列（81），以便以后分发（没有数据透视表tbl和/或公式）。
以下是到目前为止可以实现的代码： 按月声明从数据集中填充的所有数组，创建一维数组以添加所有列，然后粘贴转置到MONTH 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
答案 0 :(得分：0)
代码中可能存在多个问题。一个显然是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
希望它会有用。