Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


1384 / 13644 ツリー ←次へ | 前へ→

【74764】Excel VBA 差分用語抽出方法について TOKI 13/9/11(水) 22:26 質問[未読]
【74765】Re:Excel VBA 差分用語抽出方法について γ 13/9/11(水) 22:53 発言[未読]
【74773】Re:Excel VBA 差分用語抽出方法について γ 13/9/12(木) 19:52 発言[未読]
【74782】Re:Excel VBA 差分用語抽出方法について TOKI 13/9/13(金) 13:51 お礼[未読]

【74764】Excel VBA 差分用語抽出方法について
質問  TOKI  - 13/9/11(水) 22:26 -

引用なし
パスワード
   お世話になっております。

Excel VBAでこんなことできるのかわかりませんが、ご教授いただきたくよろしくお願いいたします。

例えば、

1.
A列の(セルA1)
具有能量回收的用戸控制方法

B列の(セルB1)
具有エネルギー回収的ユーザー控制方法

があった時に、その差分用語

2.
A1:能量、用戸
B1:エネルギー、ユーザー

を任意の別シートのA列、B列にそれぞれ出力したいのですが、

<イメージ>
A列       B列
能量       エネルギー
用戸       ユーザー

そんなことって可能なのでしょうか?
可能であれば、1.でA列、B列にそれぞれ対応した差分用語を
2.の別シートに出力していきたいです。


わかる方がおりましたら、ご教授の程よろしくお願いいたします。

【74765】Re:Excel VBA 差分用語抽出方法について
発言  γ  - 13/9/11(水) 22:53 -

引用なし
パスワード
   いわゆる最長共通部分列問題ですので、サイトを検索するとよいでしょう。

【74773】Re:Excel VBA 差分用語抽出方法について
発言  γ  - 13/9/12(木) 19:52 -

引用なし
パスワード
   参考コードを示します。

Sheet1のA列とB列を比較し、
結果をSheet2に書き出します。

標準モジュールに置いて、
main を実行します。

-------------------------------
Option Explicit

Dim lcs() As Long
Dim dic1 As Object
Dim dic2 As Object
Dim s1  As String
Dim s2  As String
Dim ws1  As Worksheet
Dim ws2  As Worksheet
  
Sub main()
  Dim k As Long

  Set ws1 = Worksheets("Sheet1")
  Set ws2 = Worksheets("Sheet2")

  '書き込み先のシートをクリアー
  ws2.UsedRange.Clear

  'A列とB列の差異を調べて結果を表示する
  For k = 1 To ws1.Cells(ws1.Cells.Rows.Count, 1).End(xlUp).Row
    diff ws1.Cells(k, 1), ws1.Cells(k, 2)
  Next
End Sub

Sub diff(r1 As Range, r2 As Range)
  Dim ar1, ar2
  Dim v
  Dim pos As Long
  Dim kk As Long

  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")

  ' 二つの文字列のLCSの長さを求める
  get_lcs r1, r2

  'それに対応する最長共通部分列を求める
  get_lcs_string r1.Value, r2.Value

  '結果をSheet2に書き込む
  pos = Application.Max(ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row, _
             ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row) _
             + 1
  ws2.Cells(pos, 1) = s1
  ws2.Cells(pos, 2) = s2
  
  '最長共通部分列に該当しない文字列を表示
  ar1 = get_partition(r1.Value, dic1)
  kk = 0
  For Each v In ar1
    If v <> "" Then
      kk = kk + 1
      ws2.Cells(pos + kk, 1).Value = v
    End If
  Next
  
  ar2 = get_partition(r2.Value, dic2)
  kk = 0
  For Each v In ar2
    If v <> "" Then
      kk = kk + 1
      ws2.Cells(pos + kk, 2).Value = v
    End If
  Next

  '最長共通部分列に該当しない文字列に、書式を設定(赤、アンダーライン)
  setColor ws2.Cells(pos, 1), ws2.Cells(pos, 2)

End Sub

Function get_lcs(r1 As Range, r2 As Range)
  Dim j As Long, k As Long

  s1 = r1.Value
  s2 = r2.Value
  ' lcs(j,k) は s1の1からjまでの部分列と
  '       s2の1からkまでの部分列との
  '       LCSの長さを示す
  ReDim lcs(0 To Len(s1), 0 To Len(s2))
  For j = 1 To Len(s1)
    For k = 1 To Len(s2)
      If Mid(s1, j, 1) = Mid(s2, k, 1) Then
        lcs(j, k) = lcs(j - 1, k - 1) + 1
      Else
        lcs(j, k) = WorksheetFunction.Max(lcs(j, k - 1), lcs(j - 1, k))
      End If
    Next
  Next
End Function

Function get_lcs_string(s1 As String, s2 As String)
  get_lcs_string_sub Len(s1), Len(s2)
End Function

Function get_lcs_string_sub(j As Long, k As Long)
  If j = 0 Or k = 0 Then Exit Function
  If Mid(s1, j, 1) = Mid(s2, k, 1) Then
    Call get_lcs_string_sub(j - 1, k - 1)
    dic1(j) = Empty   's1 の j番目の文字がLCSを構成
    dic2(k) = Empty   's2 の k番目の文字がLCSを構成
  Else
    If lcs(j - 1, k) >= lcs(j, k - 1) Then
      Call get_lcs_string_sub(j - 1, k)
    Else
      Call get_lcs_string_sub(j, k - 1)
    End If
  End If
End Function

Function get_partition(s As String, d As Object) As Variant
  Dim key

  For Each key In d.keys
    Mid$(s, key, 1) = "_"  ' 余り使用されない文字の意
  Next
  get_partition = Split(s, "_")
End Function

Function setColor(r1 As Range, r2 As Range)
  Dim j As Long, k As Long
  
  '背景色を水色
  r1.Interior.ColorIndex = 34
  r2.Interior.ColorIndex = 34
  
  'マッチしない文字列の文字色を赤に
  For j = 1 To Len(r1.Value)
    If Not dic1.exists(j) Then
      With r1.Characters(Start:=j, Length:=1).Font
        .Underline = xlUnderlineStyleSingle
        .ColorIndex = 3
      End With
    End If
  Next
  
  For k = 1 To Len(r2.Value)
    If Not dic2.exists(k) Then
      With r2.Characters(Start:=k, Length:=1).Font
        .Underline = xlUnderlineStyleSingle
        .ColorIndex = 3
      End With
    End If
  Next
End Function
---------------------------------------------

なお、
検索で最初にヒットする、
ht tp://d.hatena.ne.jp/naoya/20090328/1238251033
を参考にさせていただきました。

【74782】Re:Excel VBA 差分用語抽出方法について
お礼  TOKI  - 13/9/13(金) 13:51 -

引用なし
パスワード
   びっくりしました。

本当にありがとうございます。

自分には難しすぎて理解できませんが
レベルの高さにびっくりです。

本当にありがとうございました。

1384 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free