计算出这个变量结果是不是很难？

AACC88 · 发表于 2013-1-16 20:14

诚请高手帮忙。

lee1892 · 发表于 2013-1-18 11:29

本帖最后由 lee1892 于 2013-1-18 11:58 编辑

我真是晕倒啊！以为你有基础知识的。见下图

对象名：VBA内的名字，你可以理解为人的身份证号码，VBA里的引用方式为对象名.Range("A1")
表单名称：出现在Excel里的名字，你可以理解为人的姓名，VBA里的引用方式为，Sheets("表单名称").Range("A1")

你的明白？
还不明白的话，你把代码里的输入 Sheet2.Cells.... 改成 Sheets("....").Cells....
输出 With Sheet1 改成 With Sheets("....")

lee1892 · 发表于 2013-1-18 14:23

注意到原代码有一处有误，已经在前面改正并标识了，你自己对照改一下。

原先的代码使用字典嵌套，我机子上计算需要 14 秒 +
下面的代码使用自定义数据类型结合字典筛选已添加项，我这计算不到 2 秒 {:soso_e116:}

代码:

Type CODE_INFO
Code As String
Letter As Integer
IndCount As Long
Indexes() As Long
dInds As Object
End Type

Sub Calculation()
Dim t#, aData, aResult(), aCount&(), nInitial&
Dim i&, j&, k&, aInds(1 To 4), sIndex$
Dim dCode As Object, nDiff&, nNew&, nSmall&
Dim aCodeInfos() As CODE_INFO, nCount&, nTotalNum&
t = Timer
' ===========================================
' 输入
With Sheet1 ' 自己改，可改为 Sheets("...")
      aData = .Cells(1, 1).CurrentRegion
End With
' ===========================================
' 数据分析初始化
nTotalNum = UBound(aData)
Set dCode = CreateObject("Scripting.Dictionary")
ReDim aCount(1 To 26, 1 To 26, 1 To 26, 1 To 26)
ReDim aCodeInfos(1 To nTotalNum)
For i = 1 To nTotalNum
      For j = 1 To 4
         aInds(j) = Asc(Mid(aData(i, 3), j, 1)) - 96
      Next
      ' 统计 4 字母组合数量
      aCount(aInds(1), aInds(2), aInds(3), aInds(4)) = aCount(aInds(1), aInds(2), aInds(3), aInds(4)) + 1
      ' 统计重复数量
      If aCount(aInds(1), aInds(2), aInds(3), aInds(4)) = 2 Then
         nInitial = nInitial + 2
      ElseIf aCount(aInds(1), aInds(2), aInds(3), aInds(4)) > 2 Then
         nInitial = nInitial + 1
      End If
      ' 统计各字符对应的 4 字母组合数量
      For j = 1 To 2
         If Not dCode.exists(aData(i, j)) Then
            nCount = nCount + 1
            dCode(aData(i, j)) = nCount
            With aCodeInfos(nCount)
                  ReDim .Indexes(1 To 5, 1 To 100)
                  .Letter = aInds(j + 2)
                  .Code = aData(i, j)
                  Set .dInds = CreateObject("Scripting.Dictionary")
            End With
         End If
         With aCodeInfos(dCode(aData(i, j)))
            sIndex = Join(aInds, ",")
            If Not .dInds.exists(sIndex) Then
                  .IndCount = .IndCount + 1
                  If .IndCount > UBound(.Indexes, 2) Then
                     ReDim Preserve .Indexes(1 To 5, 1 To UBound(.Indexes, 2) + 100)
                  End If
                  .dInds(sIndex) = .IndCount
                  For k = 1 To 4
                     .Indexes(k, .IndCount) = aInds(k)
                  Next
                  .Indexes(5, .IndCount) = 0
            End If
            .Indexes(5, .dInds(sIndex)) = .Indexes(5, .dInds(sIndex)) + 1
            If j = 2 And aData(i, 1) = aData(i, 2) Then
                  .Indexes(5, .dInds(sIndex)) = .Indexes(5, .dInds(sIndex)) - 1
            End If
         End With
      Next
Next
nTotalNum = dCode.Count
dCode.RemoveAll: Set dCode = Nothing
' ===========================================
' 数据计算
ReDim Preserve aCodeInfos(1 To nTotalNum)
ReDim aResult(0 To nTotalNum, -1 To 26)
For i = 1 To 26
      aResult(0, i) = Chr(i + 96)
Next
For i = 1 To nTotalNum
      With aCodeInfos(i)
         aResult(i, -1) = .Code & ":" & Chr(.Letter + 96)
         nSmall = nInitial
         For j = 1 To 26
            nDiff = 0
            If j = .Letter Then GoTo NEXT_LET
            For k = 1 To .IndCount
                  ' 目标 4 字母组合
                  aInds(1) = .Indexes(1, k): aInds(2) = .Indexes(2, k)
                  aInds(3) = IIf(.Indexes(3, k) = .Letter, j, .Indexes(3, k))
                  aInds(4) = IIf(.Indexes(4, k) = .Letter, j, .Indexes(4, k))
                  ' 更改前，原 4 字母组合数量
                  nNew = aCount(.Indexes(1, k), .Indexes(2, k), .Indexes(3, k), .Indexes(4, k))
                  If nNew > 1 Then nDiff = nDiff - nNew
                  ' 更改后，原 4 字母组合数量
                  nNew = nNew - .Indexes(5, k)
                  If nNew > 1 Then nDiff = nDiff + nNew
                  ' 更改前，目标 4 字母组合数量
                  nNew = aCount(aInds(1), aInds(2), aInds(3), aInds(4))
                  If nNew > 1 Then nDiff = nDiff - nNew
                  ' 更改后，目标 4 字母组合数量
                  nNew = nNew + .Indexes(5, k)
                  If nNew > 1 Then nDiff = nDiff + nNew
            Next
            ' 写入结果数组
NEXT_LET:    aResult(i, j) = nInitial + nDiff
            If aResult(i, j) < nSmall Then
                  nSmall = aResult(i, j)
                  aResult(i, 0) = Chr(j + 96) & ":" & nSmall
            ElseIf aResult(i, j) = nSmall Then
                  If IsEmpty(aResult(i, 0)) Then
                     aResult(i, 0) = Chr(j + 96) & ":" & nSmall
                  Else
                     aResult(i, 0) = aResult(i, 0) & "," & Chr(j + 96) & ":" & nSmall
                  End If
            End If
         Next
         .dInds.RemoveAll: Set .dInds = Nothing
      End With
Next
' ===========================================
' 输出
With Sheet2 ' 自己改，可改为 Sheets("...")
      .Cells.ClearContents
      nNew = UBound(aResult, 1) - LBound(aResult, 1) + 1
      nSmall = UBound(aResult, 2) - LBound(aResult, 2) + 1
      .Cells(1, 1).Resize(nNew, nSmall) = aResult
End With
' ===========================================
Debug.Print Timer - t
End Sub

AACC88 · 发表于 2013-1-17 07:40

本帖最后由 AACC88 于 2013-1-18 21:49 编辑

变通说明：以上200多个符号的重复结果全部自动列出，可能很麻烦，现在可以简化为只计算出最小的一个演变结果即可。即每一个符号对应的字母可有25种变化，可转换成另外25个字母，产生25种重复数据，假如250个符号，符号对应的字母可有25种变化，产生25个重复数据，250X25=6250，若6250个数据中最小的一个数据是“ヘz转成ヘm，最小值3176”（即ヘ原来对应z，最小的一个数据是ヘ对应m），只要知道最小的一个数据是ヘm 3176就可以了。

AACC88 · 发表于 2013-1-18 10:06

烦请帮忙看一下附件。

AACC88 · 发表于 2013-1-17 09:35

期待高手帮忙。

AACC88 · 发表于 2013-1-17 11:11

哪位能帮忙解决？

AACC88 · 发表于 2013-1-18 08:52

本帖最后由 AACC88 于 2013-1-18 10:06 编辑

诚请帮忙。

lee1892 · 发表于 2013-1-17 17:30

本帖最后由 lee1892 于 2013-1-18 14:10 编辑

不知道我理解正确不：

代码:

Sub Calculation()
Dim t#, aData, aResult(), aOutput(), aCount&(), nInitial&
Dim i&, j&, k&, i1st%, i2nd%, i3rd%, i4th%, sIndex, aInds
Dim dCode As Object, aCodes, aIndexes, nDiff&, nNew&, nSmall&
t = Timer
On Error GoTo CLEAR_BUFFER
' ===========================================
' 输入
aData = Sheet2.Cells(1, 1).CurrentRegion
' ===========================================
Set dCode = CreateObject("Scripting.Dictionary")
ReDim aCount(0 To 25, 0 To 25, 0 To 25, 0 To 25)
For i = 1 To UBound(aData)
      i1st = Asc(Mid(aData(i, 3), 1, 1)) - 97
      i2nd = Asc(Mid(aData(i, 3), 2, 1)) - 97
      i3rd = Asc(Mid(aData(i, 3), 3, 1)) - 97
      i4th = Asc(Mid(aData(i, 3), 4, 1)) - 97
      sIndex = Join(Array(i1st, i2nd, i3rd, i4th), ",")
      aCount(i1st, i2nd, i3rd, i4th) = aCount(i1st, i2nd, i3rd, i4th) + 1
      If aCount(i1st, i2nd, i3rd, i4th) = 2 Then
         nInitial = nInitial + 2
      ElseIf aCount(i1st, i2nd, i3rd, i4th) > 2 Then
         nInitial = nInitial + 1
      End If
      If Not dCode.exists(aData(i, 1)) Then
         Set dCode(aData(i, 1)) = CreateObject("Scripting.Dictionary")
         dCode(aData(i, 1))("LETTER") = i3rd
      End If
      If Not dCode.exists(aData(i, 2)) Then
         Set dCode(aData(i, 2)) = CreateObject("Scripting.Dictionary")
         dCode(aData(i, 2))("LETTER") = i4th
      End If
      dCode(aData(i, 1))(sIndex) = dCode(aData(i, 1))(sIndex) + 1
      If aData(i, 1) <> aData(i, 2) Then 'If i3rd <> i4th Then 此处有误！不应比较第3列的最后两个字母，而应比较1、2列
         dCode(aData(i, 2))(sIndex) = dCode(aData(i, 2))(sIndex) + 1
      End If
Next
ReDim aResult(0 To dCode.Count, 1 To 26)
For i = 1 To 26
      aResult(0, i) = Chr(i + 96)
Next
ReDim aOutput(1 To dCode.Count, 1 To 2)
aCodes = dCode.keys
For i = 0 To UBound(aCodes)
      i1st = dCode(aCodes(i))("LETTER")
      aOutput(i + 1, 1) = aCodes(i) & ":" & Chr(i1st + 97)
      nSmall = nInitial
      For j = 0 To 25
         nDiff = 0
         If j = i1st Then GoTo NEXT_LETTER
         For Each sIndex In dCode(aCodes(i)).keys
            If sIndex = "LETTER" Then GoTo JUMP_FIRST
            aInds = Split(sIndex, ",")
            i3rd = aInds(2): i4th = aInds(3)
            If i3rd = i1st Then i3rd = j
            If i4th = i1st Then i4th = j
            If aCount(aInds(0), aInds(1), i3rd, i4th) > 1 Then
                  nDiff = nDiff - aCount(aInds(0), aInds(1), i3rd, i4th)
            End If
            If aCount(aInds(0), aInds(1), aInds(2), aInds(3)) > 1 Then
                  nDiff = nDiff - aCount(aInds(0), aInds(1), aInds(2), aInds(3))
            End If
            nNew = aCount(aInds(0), aInds(1), i3rd, i4th) + dCode(aCodes(i))(sIndex)
            If nNew > 1 Then
                  nDiff = nDiff + nNew
            End If
            nNew = aCount(aInds(0), aInds(1), aInds(2), aInds(3)) - dCode(aCodes(i))(sIndex)
            If nNew > 1 Then
                  nDiff = nDiff + nNew
            End If
JUMP_FIRST: Next
NEXT_LETTER:
         aResult(i + 1, j + 1) = nInitial + nDiff
         If aResult(i + 1, j + 1) < nSmall Then
            nSmall = aResult(i + 1, j + 1)
            aOutput(i + 1, 2) = Chr(j + 97) & ":" & nSmall
         ElseIf aResult(i + 1, j + 1) = nSmall Then
            aOutput(i + 1, 2) = aOutput(i + 1, 2) & "," & Chr(j + 97) & ":" & nSmall
         End If
      Next
      If Left(aOutput(i + 1, 2), 1) = "," Then
         aOutput(i + 1, 2) = Right(aOutput(i + 1, 2), Len(aOutput(i + 1, 2)) - 1)
      End If
Next
' ===========================================
' 输出
With Sheet1
      .Cells.ClearContents
      .Cells(2, 1).Resize(UBound(aOutput, 1), UBound(aOutput, 2)) = aOutput
      .Cells(1, 3).Resize(UBound(aResult, 1) + 1, UBound(aResult, 2)) = aResult
End With
' ===========================================
CLEAR_BUFFER:
For i = 0 To UBound(aCodes)
      dCode(aCodes(i)).RemoveAll
      Set dCode(aCodes(i)) = Nothing
Next
dCode.RemoveAll: Set dCode = Nothing
Debug.Print Timer - t
End Sub

AACC88 · 发表于 2013-1-18 21:31

本帖最后由 AACC88 于 2013-1-18 23:28 编辑

谢谢lee1892，运算速度很快，太强大了。原以为这个问题没办法解决，因而在7楼加了一个变通说明。
是否能帮忙解决一个新的类似的问题。新的附件有A、B两列，A列的字母对应B列数据的第2个字母。
B列数据第2个字母变化后的各种重复结果可仍然自动列出在sheet 3，如sheet 3“模拟结果”的举例。

Calculation测试2.rar (261.51 KB, 下载次数: 8)

		自动登录	找回密码
密码			免费注册

[已解决] 计算出这个变量结果是不是很难？

评分

评分