完善数组，brr数组第三五列怎么生成

weiyingde

microyip 发表于 2017-11-5 11:23
整个代码中只有两处才与工作表有关，其余的都可以理解为与工作表本身无关，属于计算而已

是的，我想想，不懂在向你请教。
谢谢你的热心指教。

LMY123

weiyingde 发表于 2017-11-5 11:26
是的，我想想，不懂在向你请教。
谢谢你的热心指教。

Sub 进入所有工作表执行宏()
For I = 1 To ThisWorkbook.Sheets.Count
If Sheets(I).Name = "本次统计" Or Sheets(I).Name = "全期统计" Then
Sheets(I).Select
   Call 汇总
End If
Next
End Sub
'http://club.excelhome.net/thread-792625-1-1.html

microyip

LMY123 发表于 2017-11-5 11:47
Sub 进入所有工作表执行宏()
For I = 1 To ThisWorkbook.Sheets.Count
If Sheets(I).Name = "本次统计" ...

此处Sheets.Select是没用的

weiyingde

microyip 发表于 2017-11-5 11:23
整个代码中只有两处才与工作表有关，其余的都可以理解为与工作表本身无关，属于计算而已

对实现这个目标的思路我还是疑惑不解：
不知能否实现。
我的思路是：
调用这一过程，循环工作表：
for i =1 to 2
  vData = Sheets(i).[a1].CurrentRegion.Value
  ReDim vFill(1 To 5, 1 To UBound(vData))
  …………
………………
  Next
    End If
IF i =1 then
  VfillA = Vfill
else
  VfillB = vfill
next
End Sub
我试一试，不知是否能行。

weiyingde

LMY123 发表于 2017-11-5 11:47
Sub 进入所有工作表执行宏()
For I = 1 To ThisWorkbook.Sheets.Count
If Sheets(I).Name = "本次统计" ...

我不想在工作表中实现，
因为这段代码最终要在ppt VBA模块中运行，
反复调用工作表对象，会严重影响速度。

weiyingde

microyip 发表于 2017-11-5 11:51
此处Sheets.Select是没用的

我将你的代码稍作修改如下：
蓝色使我的添加，红色是调试中出问题的代码。
Sub 汇总()
    Dim vData As Variant, vRow As Variant, nCol As Integer, r%, c%, i%
    Dim sName As String, vKey As Variant, oDic As Object, vFill As Variant, vFillA As Variant, vFillB As Variant, nFill As Long, nFillRow As Long, nOrder As Long
    Set oDic = CreateObject("Scripting.Dictionary")
    For i = 1 To 2
    vData = Sheets(i).[a1].CurrentRegion.Value
    ReDim vFill(1 To 5, 1 To UBound(vData))
    If UBound(vData) = 1 Then Exit Sub
   
    For vRow = 2 To UBound(vData)
        sName = Trim(vData(vRow, 1)) '姓名
        vKey = sName & "|" & Trim(vData(vRow, 5)) '课内容
        If Val(sName) > 0 Then sName = Application.Substitute(Replace(sName, Val(sName), ""), " ", "")
        If Not oDic.Exists(sName) Then
            nFill = nFill + 1
            oDic(sName) = nFill
            vFill(1, nFill) = sName
        End If
        nFillRow = oDic(sName)
        vFill(2, nFillRow) = vFill(2, nFillRow) + 1 '答次次数
        If Not oDic.Exists(vKey) Then
            oDic(vKey) = 0
            vFill(3, nFillRow) = vFill(3, nFillRow) + 1 '答次课数
        End If
        vFill(4, nFillRow) = vFill(4, nFillRow) + vData(vRow, 6) '总分
    Next
    If nFill > 0 Then
        ReDim Preserve vFill(1 To 5, 1 To nFill)
        vData = Application.WorksheetFunction.Transpose(vFill)
        vFill = Empty
        ReDim vFill(1 To nFill, 1 To 5)
        oDic.RemoveAll
        For vRow = 1 To nFill
            If oDic.Exists(vData(vRow, 4)) Then
                oDic(vData(vRow, 4)) = oDic(vData(vRow, 4)) & "|" & Trim(vRow)
            Else
                oDic(vData(vRow, 4)) = Trim(vRow)
            End If
        Next
        nFillRow = 0
        For nFill = 1 To oDic.Count
            vKey = Split(oDic(Application.WorksheetFunction.Large(oDic.keys, nFill)), "|")
            nOrder = nOrder + 1 '名次
            For Each vRow In vKey
                nFillRow = nFillRow + 1
                For nCol = 1 To 4
                    vFill(nFillRow, nCol) = vData(Val(vRow), nCol)
                Next
                vFill(nFillRow, 5) = nOrder
            Next
        Next
        'Sheet1.[J2:N2].Resize(nFillRow) = vFill
    End If
  If i = 1 Then vFillA = vFill :Else vFillB = vFill
  Next
Sheets(1).[J2:N2].Resize(UBound(vFillA)) = vFillA
  Sheets(2).[J2:N2].Resize(UBound(vFillA)) = vFillB，疏忽，此处A改为B
End Sub
另外为了循环，我将两个工作表改名为：Sheet1，Sheet2
出问题的原因是否是要是用两部字典呢？
附件见下面

yjh_27

weiyingde 发表于 2017-11-5 12:12
我将两个工作表改名为：Sheet1，Sheet2出问题的原因是否是要是用两部字典呢？

Set oDic = CreateObject("Scripting.Dictionary")
    For i = 1 To 2

位置对换

weiyingde

yjh_27 发表于 2017-11-5 12:24
位置对换

谢谢，我试试，不行你在帮我看看。

weiyingde

yjh_27 发表于 2017-11-5 12:24
位置对换

不行，还是下面一句出问题
vKey = Split(oDic(Application.WorksheetFunction.Large(oDic.keys, nFill)), "|")

weiyingde

yjh_27 发表于 2017-11-5 12:24
位置对换

是不是每一次循环后要清空字典呢？