FC2ブログ

スポンサーサイト 


上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

Excel VBA をやってみた その14 


何故だろう・・・ 質問者さんが質問を削除した。
他回答者さんも失礼な振る舞いをしていたとも思えない。
せっかくなので、ここで紹介・解説してみる

質問の内容は、

Sheet1の列Aの1行目から列XA200行目まで
すべての各セルに 22,22,45 のようにカンマで区切られた塊が書かれている。
このセル同士をひとつずつ順番にA列の1行目のセルにかいてあるものを基準にして比較していき、
もし同じ内容のセルがあった場合は、例えば、A1 と B2 が同じだったら「A列1行目とB列2行目」と
A列の300行目から文字として書き起こしていきます。
基準にするセルを変えながら参照し、比較し同じものを探すコードを教えてください。

というものに、以下を初期回答したのですが・・・
(初期回答というのは、この後、性能向上版を提示する為に回答削除・回答し直ししてました)

以下でどうでしょう
10秒もあれば終わると思います。
(試したデータでは5秒くらいでしたが・・・(最終行:15078))

Public Sub Samp1()
  Dim dic As Object, dicW As Object
  Dim vA As Variant, v As Variant, vv As Variant
  Dim sS As String
  Dim i As Long, j As Long

  Application.ScreenUpdating = False
  Set dic = CreateObject("Scripting.Dictionary")
  Set dicW = CreateObject("Scripting.Dictionary")
  vA = Range("A1:XA200").Value
  For j = 1 To UBound(vA, 2)
    For i = 1 To UBound(vA)
      sS = dicW(vA(i, j))
      If (Len(sS) > 0) Then
        If (dic.Exists(vA(i, j))) Then
          sS = dic(vA(i, j))
        Else
          v = Split(sS, "_")
          v(2) = Split(Cells(1, Int(v(1))).Address, "$")(1)
          sS = Join(v, "_")
        End If
        dic(vA(i, j)) = sS & "," _
          & i & "_" & j & "_" & Split(Cells(1, j).Address, "$")(1)
      Else
        dicW(vA(i, j)) = i & "_" & j & "_"
      End If
    Next
  Next

  If (dic.Count > 0) Then
    i = 0
    With Range("A300")
      For Each vA In dic.Items
        v = Split(vA, ",")
        ReDim vv(UBound(v))
        For j = 0 To UBound(v)
          vv(j) = Split(v(j), "_")
        Next
        For j = 1 To UBound(vv)
          sS = vv(0)(2) & " 列 " & vv(0)(0) & " 行目と " _
            & vv(j)(2) & " 列 " & vv(j)(0) & " 行目"
          .Offset(i).Resize(, 3) = _
            Array(sS, vv(0)(0), vv(0)(1))
          i = i + 1
        Next
      Next
      With .Resize(i, 3)
        .Sort .Cells(3), xlAscending, .Cells(2), Header:=xlNo
        .Offset(, 1).Resize(, 2).ClearContents
      End With
    End With
  End If
  Set dic = Nothing
  Set dicW = Nothing
  Application.ScreenUpdating = True
End Sub


※ テスト用データは以下で作成していました

Public Sub test()
  Dim r As Range
  Dim sS As String
  Dim i As Long

  Randomize
  Application.ScreenUpdating = False
  For Each r In Range("A1:XA200")
    sS = ""
    For i = 1 To 3
      sS = sS & "," & Int(78 * Rnd()) + 22
    Next
    r = Mid(sS, 2)
  Next
  Columns.AutoFit
  Application.ScreenUpdating = True
End Sub


そんなにヘンテコな記述じゃないと思うのですが・・・
まぁ、コメントも入れていないので、以降解説していきます。

※ 後半には、質問者さんは何か・・・ Find を使った方法を求めていた??? みたいなので
Find を使った記述にも触れています。
どの様な処理をしているのかを解説する前に、性能向上版として回答し直した内容を紹介しておきます。

性能向上版を記述する為に回答し直しています。

初期回答は、Samp1
向上版が、Samp2(出力が重ならない様に E300 ~)
2~3割、速くなってます。

Public Sub Samp1()
  Dim dic As Object, dicW As Object
  Dim vA As Variant, v As Variant, vv As Variant
  Dim sS As String
  Dim i As Long, j As Long

  Application.ScreenUpdating = False
  Set dic = CreateObject("Scripting.Dictionary")
  Set dicW = CreateObject("Scripting.Dictionary")
  vA = Range("A1:XA200").Value
  For j = 1 To UBound(vA, 2)
    For i = 1 To UBound(vA)
      sS = dicW(vA(i, j))
      If (Len(sS) > 0) Then
        If (dic.Exists(vA(i, j))) Then
          sS = dic(vA(i, j))
        Else
          v = Split(sS, "_")
          v(2) = Split(Cells(1, Int(v(1))).Address, "$")(1)
          sS = Join(v, "_")
        End If
        dic(vA(i, j)) = sS & "," _
          & i & "_" & j & "_" & Split(Cells(1, j).Address, "$")(1)
      Else
        dicW(vA(i, j)) = i & "_" & j & "_"
      End If
    Next
  Next

  If (dic.Count > 0) Then
    i = 0
    With Range("A300")
      For Each vA In dic.Items
        v = Split(vA, ",")
        ReDim vv(UBound(v))
        For j = 0 To UBound(v)
          vv(j) = Split(v(j), "_")
        Next
        For j = 1 To UBound(vv)
          sS = vv(0)(2) & " 列 " & vv(0)(0) & " 行目と " _
            & vv(j)(2) & " 列 " & vv(j)(0) & " 行目"
          .Offset(i).Resize(, 3) = _
            Array(sS, vv(0)(0), vv(0)(1))
          i = i + 1
        Next
      Next
      With .Resize(i, 3)
        .Sort .Cells(3), xlAscending, .Cells(2), Header:=xlNo
        .Offset(, 1).Resize(, 2).ClearContents
      End With
    End With
  End If
  Set dic = Nothing
  Set dicW = Nothing
  Application.ScreenUpdating = True
End Sub

Public Sub Samp2()
  Dim dic As Object, dicW As Object
  Dim vA As Variant, v As Variant, vv As Variant
  Dim sS As String, sC As String
  Dim i As Long, j As Long

  Application.ScreenUpdating = False
  Set dic = CreateObject("Scripting.Dictionary")
  Set dicW = CreateObject("Scripting.Dictionary")
  vA = Range("A1:XA200").Value
  ReDim v(2)
  For j = 1 To UBound(vA, 2)
    v(1) = j
    v(2) = Split(Cells(1, j).Address, "$")(1)
    For i = 1 To UBound(vA)
      v(0) = i
      vv = dicW(vA(i, j))
      If (IsArray(vv)) Then
        dic(dic.Count) = Array(vv, v)
      Else
        dicW(vA(i, j)) = v
      End If
    Next
  Next

  If (dic.Count > 0) Then
    ReDim vA(1 To dic.Count, 1 To 3)
    i = 1
    For Each v In dic.Items
      sS = v(0)(2) & " 列 " & v(0)(0) & " 行目と " _
        & v(1)(2) & " 列 " & v(1)(0) & " 行目"
      vA(i, 1) = sS
      vA(i, 2) = v(0)(0)
      vA(i, 3) = v(0)(1)
      i = i + 1
    Next

    With Range("E300").Resize(dic.Count, 3)
      .Value = vA
      .Sort .Cells(3), xlAscending, .Cells(2), Header:=xlNo
      .Offset(, 1).Resize(, 2).ClearContents
    End With
  End If
  Set dic = Nothing
  Set dicW = Nothing
  Application.ScreenUpdating = True
End Sub

※ テスト用データは以下で作成していました

Public Sub test()
  Dim r As Range
  Dim sS As String
  Dim i As Long

  Randomize
  Application.ScreenUpdating = False
  For Each r In Range("A1:XA200")
    sS = ""
    For i = 1 To 3
      sS = sS & "," & Int(78 * Rnd()) + 22
    Next
    r = Mid(sS, 2)
  Next
  Columns.AutoFit
  Application.ScreenUpdating = True
End Sub

質問者さんの機嫌を損ねるような内容だったのかなぁ?

というのは、置いといて

まず、A1:XA200 のテストデータを作成します。
XA 列っていうと、625 列・・・ の 200 行・・・ 125,000 セル
グルんグルん回りながら、22~99 までの値3つをカンマ区切りで繋げたものを設定していきます。

要求動作は、A1 から A2、A3・・・A200、B1・・・B200、・・・ XA200 と同じ内容のものを探して、
どこの行・列と、どこの行・列が同じ・・・を、リスト化していくもの・・・
考え方としては、
・1つ1つ同じものが他セルにあるか・・・を探す
ではなく、
・この内容は、セル行・列にありましたよ・・・を随時覚えていって・・・
 同じ内容のものが既にあったら、リスト化していく・・・
としました。
前者の処理では、
A1 の内容を求める時には、124,999 セル探す対象に・・・
A2 の内容を求める時には、124,998 セル探す対象に・・・
実際には、回り込んで自分自身も探さないと、全部を探した判別が出来ないと思うので、
毎回毎回 125,000 セルを探す・・・・ 気の遠くなる時間が必要そう・・・
後者では、125,000 セルの内容を随時覚えるだけなので・・・・速いんでしょう・・・

Samp1 での以下処理部分が覚えるものになっています
  vA = Range("A1:XA200").Value
  For j = 1 To UBound(vA, 2)
    For i = 1 To UBound(vA)
      sS = dicW(vA(i, j))
      If (Len(sS) > 0) Then
        If (dic.Exists(vA(i, j))) Then
          sS = dic(vA(i, j))
        Else
          v = Split(sS, "_")
          v(2) = Split(Cells(1, Int(v(1))).Address, "$")(1)
          sS = Join(v, "_")
        End If
        dic(vA(i, j)) = sS & "," _
          & i & "_" & j & "_" & Split(Cells(1, j).Address, "$")(1)
      Else
        dicW(vA(i, j)) = i & "_" & j & "_"
      End If
    Next
  Next

処理としては、Dictionary を2つ(dic dicW)用意して、キーをセル内容とします。
重複チェックをするのが、dicW
      sS = dicW(vA(i, j))
登録されていなかったら、dicW からの戻り値は Empty なので、sS = "" となります。
登録されていなかったら、行_列_ の文字列を登録しておきます。
例えば、A2 用の登録データは、"2_1_" となります。

で、既に登録されていたら、Len(sS) > 0 となります。
ペアのデータを管理するのが、dic
ペアとして管理していなかったら、sS の内容に列文字を追加したもの
sS = "2_1_" だったら、
          v = Split(sS, "_")
          v(2) = Split(Cells(1, Int(v(1))).Address, "$")(1)
          sS = Join(v, "_")
"2_1_A" に加工して、今回が 3行 1列なら
        dic(vA(i, j)) = sS & "," _
          & i & "_" & j & "_" & Split(Cells(1, j).Address, "$")(1)
で、"2_1_A,3_1_A" を dic に登録しておきます。
ペアとして管理していたら、前回の文字列+今回の文字列を継ぎ足す・・・
例えば、前回の文字列が "2_1_A,3_1_A" で、今回が 3行 2列なら "2_1_A,3_1_A,3_2_B" に更新します。

リスト化出力では、dic に格納されているもののみを処理すれば終わり・・・ということで
    i = 0
    With Range("A300")
      For Each vA In dic.Items
        v = Split(vA, ",")
        ReDim vv(UBound(v))
        For j = 0 To UBound(v)
          vv(j) = Split(v(j), "_")
        Next
        For j = 1 To UBound(vv)
          sS = vv(0)(2) & " 列 " & vv(0)(0) & " 行目と " _
            & vv(j)(2) & " 列 " & vv(j)(0) & " 行目"
          .Offset(i).Resize(, 3) = _
            Array(sS, vv(0)(0), vv(0)(1))
          i = i + 1
        Next
      Next
      With .Resize(i, 3)
        .Sort .Cells(3), xlAscending, .Cells(2), Header:=xlNo
        .Offset(, 1).Resize(, 2).ClearContents
      End With
    End With

セルの内容自体は出力する必要はないので、格納していた文字列だけを処理
"2_1_A,3_1_A,3_2_B" という文字列が得られたら、カンマで分割して
v(0) = "2_1_A"
v(1) = "3_1_A"
v(2) = "3_2_B"
で、それをさらに _ で分割
vv(0)(0) = "2"
vv(0)(1) = "1"
vv(0)(2) = "A"
vv(1)(0) = "3"
vv(1)(1) = "1"
vv(1)(2) = "A"
vv(2)(0) = "3"
vv(2)(1) = "2"
vv(2)(2) = "B"
これを、vv(0) と vv(他)とを結び付けて文字列化すれば・・・
Excel に出力した際に、処理した順番に見せかけるために、
行・列(vv(0)(0)、vv(0)(1))も一緒に書き出しておいて、それを用いてソート後、行・列部分を綺麗に

Samp1 での処理解説はこんな感じです。
実際にやってみると、
・重複は結構あったり
・同じ列文字を求める Split(Cells(1, j).Address, "$")(1) 事も多く
・どうせソートするのなら、単純にペアだけを覚えておけば・・・

これを改善したのが、Samp2 になります。

dicW の役割は同じですが、登録するデータは配列
この配列は、Samp1 で出力時に文字列を展開した後の vv(0) の内容と同じ
v(0) = 行
v(1) = 列
v(2) = 列文字
  ReDim v(2)
  For j = 1 To UBound(vA, 2)
    v(1) = j
    v(2) = Split(Cells(1, j).Address, "$")(1)
    For i = 1 To UBound(vA)
      v(0) = i
      vv = dicW(vA(i, j))
      If (IsArray(vv)) Then
        dic(dic.Count) = Array(vv, v)
      Else
        dicW(vA(i, j)) = v
      End If
    Next
  Next
既に覚えていたセル内容であれば、dicW の戻り値は配列になっているので・・・
dic の使い方は異なり、ペア情報を格納できれば良いので、キーは重ならない様に連番で・・・
単純にペア情報として覚えていたので、何行の結果になる・・・これがわかるので
必要分の配列を用意して、そこにデータを展開
  If (dic.Count > 0) Then
    ReDim vA(1 To dic.Count, 1 To 3)
    i = 1
    For Each v In dic.Items
      sS = v(0)(2) & " 列 " & v(0)(0) & " 行目と " _
        & v(1)(2) & " 列 " & v(1)(0) & " 行目"
      vA(i, 1) = sS
      vA(i, 2) = v(0)(0)
      vA(i, 3) = v(0)(1)
      i = i + 1
    Next

    With Range("E300").Resize(dic.Count, 3)
      .Value = vA
      .Sort .Cells(3), xlAscending, .Cells(2), Header:=xlNo
      .Offset(, 1).Resize(, 2).ClearContents
    End With
  End If
この配列を一気に Excel に書出して、ソートして、不要な部分をクリア・・・
一気に書き出すだけでも速くはなりますね・・・
何回も Split する事もなくなる分、速くなりますね・・・

う~~ん・・・と、
何か結果表示部分を見ていると、行・列の文字数が統一されていないので・・・読みにくい??・・・
という事で、行部分を3文字、列部分を2文字・・・統一しましょうか・・・
色々な方法があると思いますが RSet を使ってみました。

Public Sub Samp21()
  Dim dic As Object, dicW As Object
  Dim vA As Variant, v As Variant, vv As Variant
  Dim s2a As String * 2, s3a As String * 3
  Dim s2b As String * 2, s3b As String * 3

  Dim sS As String
  Dim i As Long, j As Long
  Dim st As Single

  st = Timer()
  Application.ScreenUpdating = False
  Set dic = CreateObject("Scripting.Dictionary")
  Set dicW = CreateObject("Scripting.Dictionary")
  vA = Range("A1:XA200").Value
  ReDim v(2)
  For j = 1 To UBound(vA, 2)
    v(1) = j
    v(2) = Split(Cells(1, j).Address, "$")(1)
    For i = 1 To UBound(vA)
      v(0) = i
      vv = dicW(vA(i, j))
      If (IsArray(vv)) Then
        dic(dic.Count) = Array(vv, v)
      Else
        dicW(vA(i, j)) = v
      End If
    Next
  Next

  If (dic.Count > 0) Then
    ReDim vA(1 To dic.Count, 1 To 3)
    i = 1
    For Each v In dic.Items
      RSet s2a = v(0)(2)
      RSet s3a = v(0)(0)
      RSet s2b = v(1)(2)
      RSet s3b = v(1)(0)
      sS = s2a & "列" & s3a & "行目と " _
        & s2b & "列" & s3b & "行目"

      vA(i, 1) = sS
      vA(i, 2) = v(0)(0)
      vA(i, 3) = v(0)(1)
      i = i + 1
    Next

    With Range("E300").Resize(dic.Count, 3)
      .Value = vA
      .Sort .Cells(3), xlAscending, .Cells(2), Header:=xlNo
      .Offset(, 1).Resize(, 2).ClearContents
    End With
  End If
  Set dic = Nothing
  Set dicW = Nothing
  Application.ScreenUpdating = True
  MsgBox Timer() - st & " 秒"
End Sub
この変更だけで綺麗になりますね
今回、Dim 部分で文字数を指定しておきましたが、事前に文字数分の文字を入れておくとか・・・
興味ある方は、RSet のヘルプを参照してみてください。

さて、ここからですが、
遅そうな毎回同じ内容が他にあるか探す方法( Find で探しまわる)をやってみました。
ま、実際に遅いので結果は 50 個見つけたら終わるものとしました(★部分にて)

Public Sub Samp3()
  Dim dic As Object
  Dim r As Range
  Dim sAdr As String, sAdrW As String
  Dim sA() As String
  Dim sS As String
  Dim i As Long, j As Long, k As Long

  Set dic = CreateObject("Scripting.Dictionary")
  j = 0
  With Range("A1:XA200")
    For i = 1 To .Columns.Count
      For Each r In .Columns(i).Cells
        sAdr = r.Address
        k = dic(sAdr)
        If (k = 0) Then
          Set r = .Find(r, r, , xlWhole, xlByColumns)
          If (r.Address <> sAdr) Then
            sA = Split(sAdr, "$")
            sS = sA(1) & " 列 " & sA(2) & " 行目"
            Do
              sAdrW = r.Address
              dic(sAdrW) = 1
              sA = Split(sAdrW, "$")
              sS = sS & "と " & sA(1) & " 列 " & sA(2) & " 行目"
              Set r = .FindNext(r)
            Loop While (r.Address <> sAdr)
            Range("I300").Offset(j) = sS
            j = j + 1
            If (j >= 50) Then Exit Sub ' ★
          End If
        End If
      Next
    Next
  End With
  Set dic = Nothing
End Sub

ここでの工夫部分は、
自分の内容で探したものではなくて、Find によって見つけられたもの・・・
これを覚えておいて、再度自分を元に探さない様に・・・
ん? (この表現で理解できる???・・・してください)
 
で、これを行・列を揃えるために RSet を使ったのが後述 Samp31
また、Samp31 では、セルの内容も一緒に表示するようにしています。
Samp31 を元に、出力形式を変えてみましょうか・・・というのが Samp32

この、Samp31、Samp32 については解説しません。

出力結果は、雰囲気以下のようになります。

kEnt207_1p.jpg  kEnt207_2p.jpg  kEnt207_3p.jpg

今回サンプルファイルはありません。

以下を標準モジュールに記述すれば確認できます。
Public Sub test()
  Dim r As Range
  Dim sS As String
  Dim i As Long

  Randomize
  Application.ScreenUpdating = False
  For Each r In Range("A1:XA200")
    sS = ""
    For i = 1 To 3
      sS = sS & "," & Int(78 * Rnd()) + 22
    Next
    r = Mid(sS, 2)
  Next
  Columns.AutoFit
  Application.ScreenUpdating = True
End Sub


Public Sub Samp1()
  Dim dic As Object, dicW As Object
  Dim vA As Variant, v As Variant, vv As Variant
  Dim sS As String
  Dim i As Long, j As Long
  Dim st As Single

  st = Timer()
  Application.ScreenUpdating = False
  Set dic = CreateObject("Scripting.Dictionary")
  Set dicW = CreateObject("Scripting.Dictionary")
  vA = Range("A1:XA200").Value
  For j = 1 To UBound(vA, 2)
    For i = 1 To UBound(vA)
      sS = dicW(vA(i, j))
      If (Len(sS) > 0) Then
        If (dic.Exists(vA(i, j))) Then
          sS = dic(vA(i, j))
        Else
          v = Split(sS, "_")
          v(2) = Split(Cells(1, Int(v(1))).Address, "$")(1)
          sS = Join(v, "_")
        End If
        dic(vA(i, j)) = sS & "," _
          & i & "_" & j & "_" & Split(Cells(1, j).Address, "$")(1)
      Else
        dicW(vA(i, j)) = i & "_" & j & "_"
      End If
    Next
  Next

  If (dic.Count > 0) Then
    i = 0
    With Range("A300")
      For Each vA In dic.Items
        v = Split(vA, ",")
        ReDim vv(UBound(v))
        For j = 0 To UBound(v)
          vv(j) = Split(v(j), "_")
        Next
        For j = 1 To UBound(vv)
          sS = vv(0)(2) & " 列 " & vv(0)(0) & " 行目と " _
            & vv(j)(2) & " 列 " & vv(j)(0) & " 行目"
          .Offset(i).Resize(, 3) = _
            Array(sS, vv(0)(0), vv(0)(1))
          i = i + 1
        Next
      Next
      With .Resize(i, 3)
        .Sort .Cells(3), xlAscending, .Cells(2), Header:=xlNo
        .Offset(, 1).Resize(, 2).ClearContents
      End With
    End With
  End If
  Set dic = Nothing
  Set dicW = Nothing
  Application.ScreenUpdating = True
  MsgBox Timer() - st & " 秒"
End Sub


Public Sub Samp2()
  Dim dic As Object, dicW As Object
  Dim vA As Variant, v As Variant, vv As Variant
  Dim sS As String
  Dim i As Long, j As Long
  Dim st As Single

  st = Timer()
  Application.ScreenUpdating = False
  Set dic = CreateObject("Scripting.Dictionary")
  Set dicW = CreateObject("Scripting.Dictionary")
  vA = Range("A1:XA200").Value
  ReDim v(2)
  For j = 1 To UBound(vA, 2)
    v(1) = j
    v(2) = Split(Cells(1, j).Address, "$")(1)
    For i = 1 To UBound(vA)
      v(0) = i
      vv = dicW(vA(i, j))
      If (IsArray(vv)) Then
        dic(dic.Count) = Array(vv, v)
      Else
        dicW(vA(i, j)) = v
      End If
    Next
  Next

  If (dic.Count > 0) Then
    ReDim vA(1 To dic.Count, 1 To 3)
    i = 1
    For Each v In dic.Items
      sS = v(0)(2) & " 列 " & v(0)(0) & " 行目と " _
        & v(1)(2) & " 列 " & v(1)(0) & " 行目"
      vA(i, 1) = sS
      vA(i, 2) = v(0)(0)
      vA(i, 3) = v(0)(1)
      i = i + 1
    Next

    With Range("E300").Resize(dic.Count, 3)
      .Value = vA
      .Sort .Cells(3), xlAscending, .Cells(2), Header:=xlNo
      .Offset(, 1).Resize(, 2).ClearContents
    End With
  End If
  Set dic = Nothing
  Set dicW = Nothing
  Application.ScreenUpdating = True
  MsgBox Timer() - st & " 秒"
End Sub


Public Sub Samp21()
  Dim dic As Object, dicW As Object
  Dim vA As Variant, v As Variant, vv As Variant
  Dim s2a As String * 2, s3a As String * 3
  Dim s2b As String * 2, s3b As String * 3
  Dim sS As String
  Dim i As Long, j As Long
  Dim st As Single

  st = Timer()
  Application.ScreenUpdating = False
  Set dic = CreateObject("Scripting.Dictionary")
  Set dicW = CreateObject("Scripting.Dictionary")
  vA = Range("A1:XA200").Value
  ReDim v(2)
  For j = 1 To UBound(vA, 2)
    v(1) = j
    v(2) = Split(Cells(1, j).Address, "$")(1)
    For i = 1 To UBound(vA)
      v(0) = i
      vv = dicW(vA(i, j))
      If (IsArray(vv)) Then
        dic(dic.Count) = Array(vv, v)
      Else
        dicW(vA(i, j)) = v
      End If
    Next
  Next

  If (dic.Count > 0) Then
    ReDim vA(1 To dic.Count, 1 To 3)
    i = 1
    For Each v In dic.Items
      RSet s2a = v(0)(2)
      RSet s3a = v(0)(0)
      RSet s2b = v(1)(2)
      RSet s3b = v(1)(0)
      sS = s2a & "列" & s3a & "行目と " _
        & s2b & "列" & s3b & "行目"
      vA(i, 1) = sS
      vA(i, 2) = v(0)(0)
      vA(i, 3) = v(0)(1)
      i = i + 1
    Next

    With Range("E300").Resize(dic.Count, 3)
      .Value = vA
      .Sort .Cells(3), xlAscending, .Cells(2), Header:=xlNo
      .Offset(, 1).Resize(, 2).ClearContents
    End With
  End If
  Set dic = Nothing
  Set dicW = Nothing
  Application.ScreenUpdating = True
  MsgBox Timer() - st & " 秒"
End Sub


Public Sub Samp3()
  Dim dic As Object
  Dim r As Range
  Dim sAdr As String, sAdrW As String
  Dim sA() As String
  Dim sS As String
  Dim i As Long, j As Long, k As Long

  Set dic = CreateObject("Scripting.Dictionary")
  j = 0
  With Range("A1:XA200")
    For i = 1 To .Columns.Count
      For Each r In .Columns(i).Cells
        sAdr = r.Address
        k = dic(sAdr)
        If (k = 0) Then
          Set r = .Find(r, r, , xlWhole, xlByColumns)
          If (r.Address <> sAdr) Then
            sA = Split(sAdr, "$")
            sS = sA(1) & " 列 " & sA(2) & " 行目"
            Do
              sAdrW = r.Address
              dic(sAdrW) = 1
              sA = Split(sAdrW, "$")
              sS = sS & "と " & sA(1) & " 列 " & sA(2) & " 行目"
              Set r = .FindNext(r)
            Loop While (r.Address <> sAdr)
            Range("I300").Offset(j) = sS
            j = j + 1
            If (j >= 50) Then Exit Sub ' ★
          End If
        End If
      Next
    Next
  End With
  Set dic = Nothing
End Sub


Public Sub Samp31()
  Dim dic As Object
  Dim r As Range
  Dim sAdr As String, sAdrW As String
  Dim sA() As String
  Dim s2 As String * 2, s3 As String * 3
  Dim sS As String
  Dim i As Long, j As Long, k As Long

  Set dic = CreateObject("Scripting.Dictionary")
  j = 0
  With Range("A1:XA200")
    For i = 1 To .Columns.Count
      For Each r In .Columns(i).Cells
        sAdr = r.Address
        k = dic(sAdr)
        If (k = 0) Then
          Set r = .Find(r, r, , xlWhole, xlByColumns)
          If (r.Address <> sAdr) Then
            sS = r.Value & ":"
            sA = Split(sAdr, "$")
            RSet s2 = sA(1)
            RSet s3 = sA(2)
            sS = sS & s2 & "列" & s3 & "行目"
            Do
              sAdrW = r.Address
              dic(sAdrW) = 1
              sA = Split(sAdrW, "$")
              RSet s2 = sA(1)
              RSet s3 = sA(2)
              sS = sS & "と " & s2 & "列" & s3 & "行目"
              Set r = .FindNext(r)
            Loop While (r.Address <> sAdr)
            Range("I300").Offset(j) = sS
            j = j + 1
            If (j >= 50) Then Exit Sub ' ★
          End If
        End If
      Next
    Next
  End With
  Set dic = Nothing
End Sub


Public Sub Samp32()
  Dim dic As Object
  Dim r As Range
  Dim sAdr As String, sAdrW As String
  Dim sA() As String
  Dim s2 As String * 2, s3 As String * 3
  Dim sS As String
  Dim i As Long, j As Long, k As Long

  Set dic = CreateObject("Scripting.Dictionary")
  j = 0
  With Range("A1:XA200")
    For i = 1 To .Columns.Count
      For Each r In .Columns(i).Cells
        sAdr = r.Address
        k = dic(sAdr)
        If (k = 0) Then
          Set r = .Find(r, r, , xlWhole, xlByColumns)
          If (r.Address <> sAdr) Then
            sS = r.Value & ":"
            sA = Split(sAdr, "$")
            RSet s2 = sA(1)
            RSet s3 = sA(2)
            sS = sS & s2 & "列" & s3 & "行目"
            Do
              sAdrW = r.Address
              dic(sAdrW) = 1
              sA = Split(sAdrW, "$")
              RSet s2 = sA(1)
              RSet s3 = sA(2)
              sS = sS & "と" & s2 & "列" & s3 & "行目"
              Set r = .FindNext(r)
            Loop While (r.Address <> sAdr)
            Range("I300").Offset(j) = sS
            j = j + 1
            If (j >= 50) Then
              With Range("I300").Resize(j)
                .TextToColumns .Cells(1), xlDelimited, Other:=True, OtherChar:=":"
                With .Offset(, 1)
                  .TextToColumns .Cells(1), xlDelimited, Other:=True, OtherChar:="と"
                End With
                .CurrentRegion.EntireColumn.AutoFit
              End With
              Exit Sub ' ★
            End If
          End If
        End If
      Next
    Next
  End With
  Set dic = Nothing
End Sub

 


A1 ~ XA200 が処理範囲なので、xlsm でないと・・・・

なお、確認は以下手順ですぐにできます。

・標準モジュールに上記 VBA 記述を転記します
・新規シートを作成し、全セルのフォントを等幅(例えば「MS ゴシック」)に変更します
 (Samp2、Samp21 の違いとか確認しやすい?)
・「test」を実行し、テスト用データを A1 ~ XA200 に作成します(10秒程度)
・その後、「Samp1」~「Samp32」を実行してみます

※ Samp1、Samp2、Samp21 の実行後、処理時間が MsgBox で表示されます
※ Samp32 実行後は、シートを変えて確認した方が良さそう
関連記事

2015/01/01

Category: 解説か

TB: --  /  CM: 0

top △

この記事に対するコメント

top △

コメントの投稿

Secret

top △


上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。