【excel2003 vba】指定した文字列が入力されている「セル範囲」の表示方法？

質問

◎Sheet1
　Ａ Ｂ Ｃ Ｄ Ｅ
１○○○－－
２○○○××
３－－－××
４×○－－－
※「－」は空白

上記のようにセルに「○」「×」が入力されている「Sheet1」シートがあります。（例として○×の２種類を使っていますが、本当はもっとたくさんの種類の文字列があります。）

vbaを使って、以下の一覧表を「List」シートに作成するコードを作成できませんでしょうか？

◎List
　Ａ　　　　　Ｂ
１○　　　 　×　　'文字列の種類
２A1:C2　　D2:E3 '文字列の範囲　
３B4　　　 　A4　　'同上

【ToDo】
(1)１行目に文字列（○、×）を入力する
(2)１行目に入力してある文字列が入力されているすべての「セル範囲」を２行目以降の各列に抽出する。

＊＊１セル内に「○」「×」の両方が入力されているものもある。＊＊
　⇒例えば、A1セルに「○×」と入力されていたら、「Rist」シートのA列B列の両方に「A1」が抽出されるようにしたい。

１セルごとのセル番地（○：A1,A2,B1,…）を一覧化することはできるのですが、同じ文字列をまとめた「範囲」の抽出ができないのです。

どなたかお力添えをお願いできませんでしょうか？
宜しくお願い致します。

回答No.10

KenKen_SP · ベストアンサー

調子に乗りすぎですよ。今更の前提変更は勘弁してください。

#9 は例えばシート名 Sheet(2) などがあって、それを外部参照
するセルがあると上手くいきませんね。やはり、

1.　数式を R1C1 形式絶対参照に変換する
　　s = Application.ConvertFormula(s, xlA1, xlR1C1, xlAbsolute)
2.　引用符で括られた文字列を除去
　　例） ".*?"
3.　外部参照を表す文字列を除去
　　例） '.+'?!|\[.+\].+?!
4.　必要なら R1C1 のアドレス、ブール値等を除去
　　例） R-?\d+C-?\d+:?|R-?\d+|C-?\d+
5.　1-4.の結果から関数を抽出する
　　例） ([^!-@]+?)\(

といった手順の方が良いかもしれません。後は、パターンの出来の
問題になってくるでしょう。ソースは掲載しません。

正規表現は確かにとっつきにくいのですが、初心者であっても解説
をよく読めばルールは必ず理解できます。

こんなサイトがあります。試行錯誤して下さい。
http://www.rubular.com/

既に十分な例を提示しましたし、後はご自分でどうぞ。

お礼

KenKen_SPさん

いろいろ教えていただきありがとうございます。
サイトまでご紹介していただいて感謝してます。

今ご回答を基に理想の処理結果になるように修正しています。
少しずつですが、完成に近づきつつあります。

これもKenKen_SPさんをはじめ、ご回答いただいたすべての皆様のおかげです。
KenKen_SPさんへのご回答欄をお借りしてお礼申し上げます。
ありがとうございました。

回答No.9

KenKen_SP

> 心当たりありますか？

ありますよ。#8 はロジックも正規表現のパターンも適当に書きすぎて
しまい無駄な負荷がかかっていただけかと...すみません。

関数名の抽出だけなら、

　　関数名(

と数式内の関数はその直後に必ず "（ " 記号を伴いますので、これを最短
一致検索するだけで良いのかもしれません。

// "文字列" および外部参照式、ブール値等の除去 という部分は不要かと
思いますので、コメント化しておきました。テストして必要ならコメント
解除してください。

多少はマシになったでしょうか。

Public Sub AnalyzeWorksheetFunctions()

　　Const SPECIALCELLS_VALUES_ALL = xlErrors Or xlLogical Or _
　　　　　　　　　　　　　　　　　　xlNumbers Or xlTextValues

　　Const REG_PATTERN1 As String = """.*?""|[^=\(,]*?!|&|\s|TRUE|FALSE"
　　Const REG_PATTERN2 As String = "([^!-@]+?)\("

　　Dim dic　　　　 As Dictionary
　　Dim reg　　　　 As RegExp
　　Dim mc　　　　　As MatchCollection
　　Dim m　　　　　 As Match
　　Dim rHasFormula As Range
　　Dim r　　　　　 As Range
　　Dim sFormula　　As String
　　Dim sKey　　　　As String
　　Dim rBuf()　　　As Range
　　Dim i　　　　　 As Long

　　Set dic = New Dictionary
　　Set reg = New RegExp
　　reg.Global = True

　　On Error Resume Next
　　Set rHasFormula = Cells.SpecialCells(xlCellTypeFormulas, _
　　　　　　　　　　　　　　　　　　　　 SPECIALCELLS_VALUES_ALL)
　　On Error GoTo 0
　　If rHasFormula Is Nothing Then
　　　　MsgBox "数式セルは無い", vbInformation
　　　　Exit Sub
　　End If

　　For Each r In rHasFormula.Cells
　　　　sFormula = r.Formula

　　　　' // "文字列" および外部参照式、ブール値等の除去
　　　　'reg.Pattern = REG_PATTERN1
　　　　'sFormula = reg.Replace(sFormula, "")

　　　　reg.Pattern = REG_PATTERN2
　　　　For Each m In reg.Execute(sFormula)
　　　　　　DoEvents
　　　　　　sKey = m.SubMatches(0)
　　　　　　If Not dic.Exists(sKey) Then
　　　　　　　　i = dic.Count
　　　　　　　　ReDim Preserve rBuf(i)
　　　　　　　　Set rBuf(i) = r.MergeArea
　　　　　　　　dic.Add Key:=sKey, Item:=i
　　　　　　Else
　　　　　　　　Set rBuf(dic(sKey)) = Union(rBuf(dic(sKey)), r.MergeArea)
　　　　　　End If
　　　　Next
　　Next

　　If dic.Count > 0 Then
　　　　Dim sh　 As Worksheet
　　　　Workbooks.Add
　　　　Set sh = ActiveSheet
　　　　Application.ScreenUpdating = False
　　　　With sh.Range("A1").Resize(, dic.Count)
　　　　　　.Value = dic.Keys
　　　　　　.Font.Bold = True
　　　　　　.Font.ColorIndex = 49
　　　　　　.HorizontalAlignment = xlCenter
　　　　End With
　　　　Dim x　　As Long
　　　　Dim y　　As Long
　　　　Dim vKey As Variant

　　　　x = 1
　　　　For Each vKey In dic.Keys
　　　　　　y = 2
　　　　　　For Each r In rBuf(dic(vKey)).Areas
　　　　　　　　sh.Cells(y, x).Value = r.Address
　　　　　　　　y = y + 1
　　　　　　Next
　　　　　　x = x + 1
　　　　Next
　　　　sh.Columns.AutoFit
　　　　For i = 0 To UBound(rBuf)
　　　　　　Set rBuf(i) = Nothing
　　　　Next
　　End If

　　Set reg = Nothing
　　Set dic = Nothing

End Sub

補足

うぉっ！…す、すげぇ。

…取り乱しました。
＃９でKenKen_SPさんに修正して頂いたコードで＃８補足の問題点は完全にクリアになりました。

REG_PATTERN2 の正規表現を少し変えただけすよね？
今、正規表現の勉強を兼ねてネットで調べていたんですが、全く手が出せずでした…。

＞#8 はロジックも正規表現のパターンも適当に書きすぎて
しまい無駄な負荷がかかっていただけかと...すみません。
いやいやいや。私こそ丸投げですみません。それくらい自分で考えて直せよって感じですよね…。

ここで一つ質問なんですけれど、現時点でのコードは数式から「関数名」とその「セル範囲」の抽出をしていると思います。

ではなくて、数式から「セル参照部分だけを抜いた数式」とその「セル範囲」を抽出するとしたら、どの様に正規表現を変えれば出来るでしょうか？（正規表現を変えるだけで出来るのかもわからないのですが…。）
以下に具体例を挙げます。

元の数式：=ROUND(SUM(様式(2)!E63:E65),1)
抽出結果↓
今まで：ROUND A1:C3　SUM B2:C3
これから：=ROUND(SUM(),1)　B2:C3
※セル参照部分以外を抽出する

何度も質問を繰り返してすみません。

回答No.8

KenKen_SP

こんな感じ...なのかな？

数式ラベルを使っているケースには対応させてません。また正規表現
は得意ではないのできっと冗長だと思います。最小限の動作確認しか
してませんので、間違いがあるかもしれません。

'-----------------------------------------------------------
' Procedure : AnalyzeWorksheetFunctions
' Purpose　 : ワークシート内で使用されている関数レポートを作成
' Memo　　　: 要参照設定： Microsoft Scripting Runtime
'　　　　　 : 要参照設定： Microsoft VBScript Regular Expressions 5.5
'-----------------------------------------------------------
'
Public Sub AnalyzeWorksheetFunctions()

　　' 数式から余計なものを除去（空文字に置換）するパターン...(※)
　　Const REG_PATTERN1 As String = _
　　　　　""".*?""|[^=\(,]*?!" & _
　　　　　"|" & "R\[[-\d]+\]C\[[-\d]+\]|R\[[-\d]+\]C|R\[[-\d]+\]|C\[[-\d]+\]" & _
　　　　　"|" & "&|\s|TRUE|FALSE"

　　' (※)の結果から関数のみを抽出するパターン
　　Const REG_PATTERN2 As String = "([^!-@].*?)\("

　　' SpecialCells で使用する定数（なぜ定義されてないのだろ？）
　　Const SPECIALCELLS_VALUES_ALL = xlErrors Or xlLogical Or _
　　　　　　　　　　　　　　　　　　xlNumbers Or xlTextValues

　　Dim dic　　　　 As Dictionary
　　Dim reg　　　　 As RegExp
　　Dim m　　　　　 As Match
　　Dim rHasFormula As Range
　　Dim r　　　　　 As Range
　　Dim sFormula　　As String
　　Dim sKey　　　　As String
　　Dim rBuf()　　　As Range
　　Dim i As Long

　　' // 初期化
　　Set dic = New Dictionary
　　Set reg = New RegExp
　　reg.Global = True

　　' // Activesheet の数式が設定された Range を参照
　　On Error Resume Next
　　Set rHasFormula = Cells.SpecialCells(xlCellTypeFormulas, _
　　　　　　　　　　　　　　　　　　　　 SPECIALCELLS_VALUES_ALL)
　　On Error GoTo 0
　　If rHasFormula Is Nothing Then
　　　　MsgBox "数式セルは無い", vbInformation
　　　　Exit Sub
　　End If

　　' // メイン処理
　　For Each r In rHasFormula.Cells
　　　　' マッチングに都合の良い形に数式を変換する
　　　　sFormula = Application.ConvertFormula(r.Formula, _
　　　　　　　　　　　　　　　　　　　　　　　xlA1, _
　　　　　　　　　　　　　　　　　　　　　　　xlR1C1, _
　　　　　　　　　　　　　　　　　　　　　　　xlRelative)
　　　　' 関数抽出に障害となる部分を除去する
　　　　reg.Pattern = REG_PATTERN1
　　　　sFormula = reg.Replace(sFormula, "")
　　　　' 関数を抽出
　　　　reg.Pattern = REG_PATTERN2
　　　　For Each m In reg.Execute(sFormula)
　　　　　　sKey = m.SubMatches(0)
　　　　　　' Dictionary を使って関数名の重複カット
　　　　　　' 関数名別にもたせたインデックスを使って、Range型配列に
　　　　　　' 該当したセルまとめていく
　　　　　　' Dictionary の Item には Range を代入できないため
　　　　　　If Not dic.Exists(sKey) Then
　　　　　　　　i = dic.Count
　　　　　　　　ReDim Preserve rBuf(i)
　　　　　　　　Set rBuf(i) = r.MergeArea
　　　　　　　　dic.Add Key:=sKey, Item:=i
　　　　　　Else
　　　　　　　　Set rBuf(dic(sKey)) = Union(rBuf(dic(sKey)), r.MergeArea)
　　　　　　End If
　　　　Next
　　Next

　　'// 出力(適当に書いてます）
　　If dic.Count > 0 Then
　　　　Dim sh　 As Worksheet
　　　　Workbooks.Add
　　　　Set sh = ActiveSheet
　　　　Application.ScreenUpdating = False
　　　　' // 見出し
　　　　With sh.Range("A1").Resize(, dic.Count)
　　　　　　.Value = dic.Keys
　　　　　　.Font.Bold = True
　　　　　　.Font.ColorIndex = 49
　　　　　　.HorizontalAlignment = xlCenter
　　　　End With
　　　　' // アドレス
　　　　Dim x　　As Long
　　　　Dim y　　As Long
　　　　Dim vKey As Variant
　　　　x = 1
　　　　For Each vKey In dic.Keys
　　　　　　y = 2
　　　　　　For Each r In rBuf(dic(vKey)).Areas
　　　　　　　　sh.Cells(y, x).Value = r.Address
　　　　　　　　y = y + 1
　　　　　　Next
　　　　　　x = x + 1
　　　　Next
　　　　sh.Columns.AutoFit
　　　　For i = 0 To UBound(rBuf)
　　　　　　Set rBuf(i) = Nothing
　　　　Next
　　End If

　　Set reg = Nothing
　　Set dic = Nothing

End Sub

補足

KenKen_SPさん

こんにちわ。
またご協力頂きありがとうございます。

上記コードを実際の対象シートで実行したところ。私の思い通りの一覧ができました。分かりづらい質問文で私の意図を読み取っていただきありがとうございます。

UnionやAreasの存在を知らなかったため、「範囲」に悩んでいたようです。勉強不足ですね。

先に「思い通り」と記載しましたが、正確に言うと若干余計なリストも抽出されてしまいます。以下に具体的な内容を記載します。

◆コードによって作成される新Bookの内容
関数名：セル範囲　
ROUND：$E$4:$E$6 $I$4:$I$6
SUM：$G$6　$O$6
AVERAGE：$B$10:$C$17　$F$10:$G$17
RC/*100-100),-1*：$D$14
R/*100-100),-1*：$E$14　$H$14:$I$14

↑見づらくてすみません。
ROUND、SUM、AVERAGEについては、何度試しても問題ないです。

しかし、
RC/*100-100),-1*　が関数名として抽出されてしまっています。
$D$14　の元の数式は、=ROUND((B14/B13*100-100),-1*(-1))　です。

reg.Pattern = REG_PATTERN1 or REG_PATTERN2 で「除去」に失敗していると言うことなのでしょうか。

上記の通りROUND、SUM、AVERAGEについては常に同じ結果なのですが、
RC/*100-100),-1*
R/*100-100),-1*
R*100-100),-1*
…等がコードを実行する度に変わるのです。
（⇒ROUND、SUM、AVERAGEのみの時もあれば、RC…等が抽出される時もある）

何が原因でこのような処理結果になるのかが分かりませんでした。
KenKen_SPさんはお心当たりありますか？

回答No.7

KenKen_SP

こんばんは。

どうやってるのか全然ご質問文から読み取れませんが、

> １セルごとのセル番地（○：A1,A2,B1,…）を一覧化することはできる

のであれば、Union でまとめればよいだけでは？その後、Areas
でブロック毎にアドレスを拾うだけです。

関数の抽出はできてるのですか？

回答No.6

n-jun

n-junです。

元のデータはセルの”数式”ですよね？”値”ではないですよね？
前の質問の実行結果がどうなるのかがわからなかったものですから、もし”値”なら
少しは頭が回るかも・・・？

－－－－－－－－－
＃５さんご指摘の件ですが、
【「禁止事項ガイドライン」一部改定に関して】
http://faq.okwave.jp/EokpControl?&event=IE0004&wid=949179&target=faq
により「丸投げ・依頼」の項目が削除されてるようです。

補足

n-junさん

また巻き込んですみません…。

＞元のデータはセルの”数式”ですよね？”値”ではないですよね？
”値”です！
本来は、”数式”から直接「セル範囲」を抽出したかったのですが、どうも厳しいようなので「一段階」置くことを考えました。

＃５の補足にも記載しましたが、もともと”数式”だったセルから”関数名”のみを抜き出して、別シートの同一セル番地に”関数名”が記載します（ここまでは今回とは別コードで対応）。
そのシート（n-junが仰った「元のデータ」はこのシートのデータ）から”関数名”ごとの「セル範囲」を抽出させることを考えました。

この質問の中で、「私の考え」が少しブレてしまいました。
すみませんでした。
また書き込んで頂いて光栄です。

回答No.5

imogasi

質問の意味が判った人も有るようだが、私には十分はわからない。○☓など判リ難い抽象的な例でなく、文字列らしいから、より実例に近いもの（文字列）で説明してもらえませんか。質問者は誰でも回答してもらえばよいかもしれませんが、読まされる方は釈然としない。
それにこの質問はコードを回答者に書かせる依頼の、丸投げ質問だと思い、規約違反でしょう。
あるセルの値について、有る文字列を含む（これはＩｎｓｔｒ関数ですぐ判る。かつＦｏｒＥａｃｈで繰り返せば簡単に判別できる。）セルをできるだけ「エクセルのセル範囲のように現す」というなら、その趣味的なことのために苦労すると思う。飛び飛びと、連続セルが不規則に起こりえるし、列、行方向に整理するとなると、なおさら難しいように思う。含むセル配置が長方形。正方形型の場合は
Ａ２：Ｃ４のように表現するのだから、シートで文字列を含むセルの長方形で、出来るだけ大きくなるように表現するのかな。アルゴリズムが難しいように思う。

補足

imogasiさん

質問がわかりづらくてすみません。
＃２の補足でも少し書いたのですが、この質問で言う「文字列」とは「関数名」です。(ex.SUM,IF,ROUND...)
もともと数式が入力されていたセルから「関数名」のみを抜き出して、別シート(今回の例では"Sheet1")で同一セル番地に「関数名」が入力されたシートが今回の対象です。

尚、もともとの数式で1つのセルに複数の関数が使用されていた場合は、"Sheet1"の同一セル番地に「SUM,IF」等「,」で区切って入力されていることを想定しています。

＞「エクセルのセル範囲のように現す」というなら、その趣味的なことのために苦労すると思う
確かにご指摘通り趣味的なことの様に思われるかもしれません。しかし「エクセルのセル範囲のように現す」ことが、私がしようとしている最終地点なのです。
どうしても必要なのです。どうかご理解ください。

ちなみに、関数名が入力されているセルは長方形、正方形型、あるいは単体(A1,D3,...)等がごちゃまぜで配置されています。

質問の意図は伝わりましたでしょうか？
説明がうまくいかず不快な思いをさせてすみません。

回答No.4

hotosys

こんなのはどうでしょうか？
作業シートを使います。
Sub sample()
Dim dataRangeAddress As String
Dim tempSheet As Worksheet
Dim foundRangeAddress As String
Dim searchStr() As String
Dim d() As String
Dim i As Integer
dataRangeAddress = "A1:E4" 'データ範囲
Set tempSheet = Sheets("Sheet2") '作業シート
For i = 1 To Sheets("List").Cells(1, Columns.Count).End(xlToLeft).Column
tempSheet.Range(dataRangeAddress).Formula = "=IF(ISERROR(FIND(""" & Sheets("List").Cells(1, i) & """,Sheet1!A1,1)),"""",1)" '=IF(ISERROR(FIND("○",Sheet1!A1,1)),"",1)と言う式を入れる
If tempSheet.Range(dataRangeAddress).Find(1, LookIn:=xlValues) Is Nothing Then '範囲内の1を探す(SpecialCellsでのエラー回避用)
foundRangeAddress = "" '範囲に1が無い
Else
foundRangeAddress = tempSheet.Range(dataRangeAddress).SpecialCells(xlCellTypeFormulas, xlNumbers).Address(False, False) '[編集][ジャンプ][セル選択]で1のセルを取得
End If
Sheets("List").Cells(2, i).Resize(Rows.Count - 1, 1).Cells.Clear '結果クリア
d = Split(foundRangeAddress, ",") '各々範囲をカンマで分ける
If UBound(d) >= 0 Then
Sheets("List").Cells(2, i).Resize(UBound(d) + 1, 1) = WorksheetFunction.Transpose(d) '行方向に答えを格納
End If
Next
End Sub

ただし、SUMでSUMIFやDSUMも見つけてしまいます。
回避方法としては
tempSheet.Range(dataRangeAddress).Formula = "=IF(ISERROR(FIND(""" & Sheets("List").Cells(1, i) & """,Sheet1!A1,1)),"""",1)" '=IF(ISERROR(FIND("○",Sheet1!A1,1)),"",1)と言う式を入れる
の部分をセル毎に正規表現でチェックする必要があると思います。
なので、
tempSheet.Range(dataRangeAddress).Formula = "=IF(ISERROR(FIND(""" & Sheets("List").Cells(1, i) & """,Sheet1!A1,1)),"""",1)" '=IF(ISERROR(FIND("○",Sheet1!A1,1)),"",1)と言う式を入れる
を
Dim re As Object
Dim r As Long
Dim c As Integer
Set re = CreateObject("VBScript.RegExp")
re.Pattern = "\W" & Sheets("List").Cells(1, i) & "\W"
're.IgnoreCase = True '大文字と小文字を区別しない場合
For r = 1 To tempSheet.Range(dataRangeAddress).Rows.Count
For c = 1 To tempSheet.Range(dataRangeAddress).Columns.Count
tempSheet.Cells(r, c) = IIf(re.Test(" " & Sheets("Sheet1").Cells(r, c).Value & " "), "=1", "")
Next
Next
Set re = Nothing
に変更してみてください。

p.s.
"=1"をセルに代入してる部分は１でもいいのですが、少し下のxlCellTypeFormulasをxlCellTypeConstantsに変更する必要があります。
正規表現は不得意なので、ちょっとごまかしてます。（検索パターンが最初か最後だった場合の正規表現をごまかしてtest文字列の方に手を加えている）
セルの内容によってはre.Patternとre.Testの部分を変更してください。

補足

hotosysさん

ご回答ありがとうございます。
いろいろ試した結果。。。うまいこといきました！！！（あくまで私が作成したテスト用データでの結果ですが。）
うまくいったとき感動しました。（素人なもので…）
ありがとうございます。

＞ただし、SUMでSUMIFやDSUMも見つけてしまいます。
hotosysさんにご提示頂いた回避方法でうまくいきました！

＞"=1"をセルに代入してる部分は１でもいいのですが、…
＞正規表現は不得意なので、…
私は、正規表現どころかvba初心者なので理解できませんでした…

そして、問題は「処理速度」です。
実際に対象となるシートは"A1:E4"の程度の範囲ではなく何十倍もの範囲なのです…。
しかも、それが約800ファイル程あるのです…。（セルの使用範囲はシート毎にまちまち）
くやしいです…。

For r = 1 To tempSheet…Nextのくだりで処理時間が掛っているのではないかと見受けますが、なにか処理速度がupするイイ方法はありませんでしょうか？
私もhotosysさんのコードを読み解きながら考えているのですが難しくて…
3連休の間ずっと唸っております…。

回答No.3

n-jun

n-junです。

関数を判断させるとなると例えば「SUMIF」を使っていた場合、「SUM」なのか
「SUMIF」なのか判断させるのも大変そうですし、複合した数式だと更に大変そうです。

http://okwave.jp/qa4867078.html
のやり取りからみても、私にはちょっとお手上げです。

お礼

＞http://okwave.jp/qa4867078.html​のやり取りからみても、
ご覧頂きましたか…。ご面倒をお掛けしました。
上記質問の際、KenKen_SPさんのご回答により関数名の洗い出しはほぼできるようになりました。

その関数名を基にfindメソッドでセル番地の洗い出し→関数ごとの使用範囲がわからないものかと悩んでいました。（今のところ良い考えが浮かばず…）

お手数をお掛けしました。
またの機会に再びお力をお貸しいただけたら幸いです。

回答No.2

n-jun

n-junです。

＞＊＊１セル内に「○」「×」の両方が入力されているものもある。＊＊
＞　⇒例えば、A1セルに「○×」と入力されていたら、「Rist」シートのA列B列の両方に「A1」が抽出されるようにしたい。
見落としてましたので＃１はスル～して下さい。

＊文字列が１文字を基準とするのか、２文字以上もあり得るのかでかわってきますので。
・「○」と「×」
・「みかん」と「りんご」
など【文字数＝振り分ける単語数】を満たすかどうかです。

補足

n-junさん

さっそくのご回答ありがとうございます。
＞＊文字列が１文字を基準とするのか、２文字以上もあり得るのかでかわってきますので。
「２文字以上の文字列」しかないです。投稿する上で２文字以上だと表現しづらかったので、○×で表現しました。（混乱させてごめんなさい。）

＞【文字数＝振り分ける単語数】を満たすかどうかです。
↑ではないです。（n-junさんの仰ることを理解していないかもしれませんが…）

◆具体的にお話しします。
１行目の文字列は既に決まっていて、「SUM」「IF」等の関数名が並んでいます。
上記の関数名リストを基に、「SUM」ならSUM関数が使用されている「セル範囲」を「List」シートの「SUM」列に抽出したいのです。

＞＊＊１セル内に「○」「×」の両方が入力されているものもある。＊＊
と記載しましたが、これは１セル内（ex.A1）にSUM関数とIF関数の両方が使用されている場合がある。という意味です。
なので、「SUM」列「IF」列の両方に「A1」という表示をしたいのです。

私の質問の意図が伝わりましたでしょうか？
分かりにくくてすみません。

回答No.1

n-jun

もっとスッキリとしたコードがあるかと思いますが、

Sub　try()
　Dim　myDic　As　Object
　Dim　r　As　Range,　rr　As　Range
　Dim　i　As　Integer
　Dim　v,　vv,　myKey

　Set　myDic　=　CreateObject("Scripting.Dictionary")

　For　Each　r　In　Worksheets("Sheet1").UsedRange
　　　　　If　r.Value　<>　""　Then
　　　　　　　　myDic(r.Value)　=　myDic(r.Value)　&　r.Address(0,　0)　&　","
　　　　　End　If
　Next

　i　=　1

　For　Each　myKey　In　myDic.keys
　　　　　For　Each　v　In　Split(myDic(myKey),　",")
　　　　　　　　　If　v　<>　""　Then
　　　　　　　　　　　　If　rr　Is　Nothing　Then
　　　　　　　　　　　　　　　Set　rr　=　Range(v)
　　　　　　　　　　　　Else
　　　　　　　　　　　　　　　Set　rr　=　Union(rr,　Range(v))
　　　　　　　　　　　　End　If
　　　　　　　　　End　If
　　　　　Next
　　　　　vv　=　Split(rr.Address(0,　0),　",")
　　　　　Set　rr　=　Nothing

　　　　　With　Worksheets("List")　'　書き出すシート
　　　　　　　　　　　.Cells(1,　i).Value　=　myKey
　　　　　　　　　　　.Cells(2,　i).Resize(UBound(vv)　+　1).Value　=　_
　　　　　　　　　　　　Application.Transpose(vv)
　　　　　　　　　　　i　=　i　+　1
　　　　　End　With
　Next
　Set　myDic　=　Nothing
　Erase　vv
End　Sub

ご参考程度に。