VBA：複数のシートを参照し、テキストに変換したい

Question

前提・実現したいこと

sheet1の設問・回答番号を複数のシートを参照し、一致した場合にテキストへ変換したいです。

自身で対応できた範囲はコードへ記述しました
sheet1のA列とsheet2のA列が一致した場合、sheet2のB列に置換するという初歩的な所までです。

こちらを応用し対応できるかご教示いただけないでしょうか。

■sheet1の回答番号をテキストへ変換したい（既にテキストのセルはそのまま）
背景が青を実行後、緑にしたい

■sheet1の2行目以下の数字はanswertitleのD列を置換したい
条件がsheet1　1行目のQ1...がanswertitle　A列と一致している、かつ2行目以下の数字がC列と一致している
ただし、Q4のように_1・_2...となってる複数回答の場合は1のみしか存在しないためA列が一致してればOK

■sheet1の1行目　Q1...はtitle　A列が一致した場合、B列を置換したい
ただし、Q4のように_1・_2となってる複数回答の場合は_1のみ変換。_2以降は空白

※複数回答時の設問・回答内容が変だと思いますが、ランダムに設定したため気になさらないようお願いいたします。

■追加のイメージ

該当のソースコード

Sub テキストに置換()

    Dim st1 As Worksheet
    Dim st2 As Worksheet
    Dim result As Range
    Dim r As Long

    Set st1 = Worksheets("Sheet1")
    Set st2 = Worksheets("Sheet2")

    r = 2
    Do While st1.Cells(r, 1).Value <> ""
        Set result = st2.Range("A:A").Find(st1.Cells(r, 1).Value)
            If Not result Is Nothing Then
                st1.Cells(r, 1).Value = st2.Cells(result.Row, 2).Value
            End If
    r = r + 1
    DoEvents
    Loop
    
End Sub

Comments

[hatena19]

コードには Worksheets("Sheet2") とありますが、画像には Sheet2 はないようですが。
画像の方を信じていいのでしょうか。

タイトルは titleのB列を縦横変換して貼り付ければよさそうですが、
実際のものは、並び順が一致していない場合もあるのでしょうか。

[退会済みユーザー]

ご確認ありがとうございます。

コードには Worksheets("Sheet2") とありますが、画像には Sheet2 はないようですが。
画像の方を信じていいのでしょうか。
＞はい、画像が最新となります。
　sheet2を記述しているのは、自身で対応しようと試みましたが
　sheet1のA列とsheet2のA列が一致した場合、sheet2のB列をsheet1のA列に置換する
　という部分までしか対応できず、そのコードを記述させていただきました。

タイトルは titleのB列を縦横変換して貼り付ければよさそうですが、
実際のものは、並び順が一致していない場合もあるのでしょうか。
＞並び順は必ず上からQ1～順番通りになっております。
　そのため並び順は一致しております。

Answer 1

表頭に1行加えて、配列数式を使う方法でもいいのではと思います。
セルに次の式を入力して
＝IF((Sheet2!A2:A17=Sheet1!A1)(Sheet2!B2:B17=Sheet1!A2)(Sheet2!C2:C17=Sheet1!A3),Sheet2!D2:D17)
Shit+Ctrl+Enterキーを押します。
![ここに

上記では、できないというか誤りですので下記のように修正します。
数式＞名前の管理＞新規作成
余裕を持って
参照範囲　Sheet2!$A$1:$A$1000 名前　label
参照範囲　Sheet2!$B$1:$B$1000 名前　id
参照範囲　Sheet2!$C$1:$C$1000 名前　answerKey
参照範囲　Sheet2!$D$1:$D$1000 名前　text
名前を作成

=IF(ISERROR(MATCH(A3,IF((label= A$2)*(id=A$1),answerKey),0)),"",INDEX(text,MATCH(A3,IF((label= A$2)*(id=A$1),answerKey),0),1))

を変換範囲の左上のセルに配列数式を入力して、このセルを変換範囲で数式コピー、
B列のような例外は、セルB10に式=B3、B11に式=B4以下略とする。
と変更します。

Comments

[退会済みユーザー]

ご回答ありがとうございます。
こちら参考にさせていただきます。

Answer 2

いろいろな方法があると思いますが、どちらにしてもかなり難易度は高そうです。

Dictionary を使った方法で書いてみました。

Sub テキストに置換()

    Dim st1 As Worksheet
    Dim stTitle As Worksheet
    Dim stAnswer As Worksheet
    Dim result As Range, result1 As Range
    Dim r As Long, c As Long

    Set st1 = Worksheets("Sheet1")
    Set stTitle = Worksheets("title")
    Set stAnswer = Worksheets("answer")

    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    r = 2
    With stAnswer
        Do While stAnswer.Cells(r, 1).Value <> ""
            If .Cells(r, 3).Value <> "" Then
                dic(.Cells(r, 2).Value & ":" & .Cells(r, 3).Value) = .Cells(r, 4).Value
            End If
            r = r + 1
        Loop
    End With


    With st1
        c = 1
        Do While .Cells(1, c).Value <> ""
            r = 2
            Do While .Cells(r, 1).Value <> ""
                Dim a
                a = Split(.Cells(1, c).Value, "_")
                If UBound(a) = 0 Then
                    If dic.Exists(.Cells(1, c).Value & ":" & .Cells(r, c).Value) Then
                        .Cells(r, c).Value = dic(a(0) & ":" & .Cells(r, c).Value)
                    End If
                ElseIf UBound(a) = 1 Then
                    If dic.Exists(a(0) & ":" & a(1)) Then
                        If .Cells(r, c).Value = 1 Then
                            .Cells(r, c).Value = dic(a(0) & ":" & a(1))
                        Else
                            .Cells(r, c).Value = ""
                        End If
                    End If
                End If
                r = r + 1
            Loop
            c = c + 1
        Loop

        .Rows(1).Clear
        stTitle.Range(stTitle.Cells(2, 2), stTitle.Cells(2, 2).End(xlDown)).Copy
        .Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
        Application.CutCopyMode = False

    End With
End Sub

Comments

[退会済みユーザー]

ご回答ありがとうございます。
いただいたコードで対応できました。
度重なる質問に応えていただき感謝いたします。

大変恐縮ですが、下記の場合も対応できるように改良するのは難しいでしょうか。

複数選択式の場合、最大で10まで選択肢がある想定。
かつ組み合わせが自由なため、answerはアンケートの設問順・パターンによっては当初添付した画像以外も存在してしまう。
（titleは固定です。）

画像が載せれなかったため■追加のイメージに追加いたしました。

answerが順不同でも対応できるコードを、もしご教示いただけるようでしたらお願いできたら幸いです。

アンケートの主なパターンとして下記3つとなります。
・選択式（単一選択肢）
・テキスト入力（自由記述）
・選択式（複数選択肢）

お手数をおかけしますが、ご確認お願いいたします。

Answer 3

とりあえず雰囲気だけ。

Option Explicit

Sub sample()
    
    Dim titleDic 'As Scripting.Dictionary
    Dim ansDic 'As Scripting.Dictionary
    Dim c As Range, k As String
    
   'titleを辞書に格納
    Set titleDic = CreateObject("Scripting.Dictionary")
    With Sheets("title")
        For Each c In .UsedRange.Resize(, 1)
            k = c.Value
            titleDic (k) = c.Offset(, 1).Value
        Next
    End With
    
   'answerを辞書に格納
    Set ansDic = CreateObject("Scripting.Dictionary")
    With Sheets("answer")
        For Each c In .UsedRange.Resize(, 1)
            If InStr(c.Value, "_") = 0 Then
                k = c.Value & vbTab & c.Offset(, 2).Value
            Else
                k = c.Value
            End If
            ansDic(k) = c.Offset(, 3).Value
        Next
    End With
    
    With Sheets("Sheet1")
       '各セルの値をanswer辞書で変換
        For Each c In .UsedRange.Resize(.UsedRange.Rows.Count - 1).Offset(1)
            k = .UsedRange(1, c.Column)
            If InStr(k, "_") = 0 Then
                k = k & vbTab & c.Value
            End If
            If ansDic.Exists(k) Then
                c.Value = ansDic(k)
                c.Interior.ThemeColor = xlThemeColorAccent6
            End If
        Next
        
       'titleの行をtitle辞書で変換
        For Each c In .UsedRange.Resize(1)
            If titleDic.Exists(c.Value) Then
                c.Value = titleDic(c.Value)
            ElseIf titleDic.Exists(Split(c.Value, "_")(0)) Then
                c.Value = titleDic(Split(c.Value, "_")(0))
            Else
                c.Value = ""
            End If
            c.Interior.ThemeColor = xlThemeColorAccent6
        Next
    End With
End Sub

Comments

[退会済みユーザー]

ご回答ありがとうございます。

'各セルの値をanswer辞書で変換
For Each c In .UsedRange.Resize(.UsedRange.Rows.Count - 1).Offset(1)
⇒ k = .UsedRange(1, c.Column)

上記部分で　引数の数が一致していません。とエラーになってしまうのですが原因お分かりになりますでしょうか。

お手数をおかけしますが、ご確認お願いいたします。

[jinoji]

失礼しました。
k = c.Offset(c.Row - 1).Value
ではいかがでしょうか。

[退会済みユーザー]

ご確認・返信ありがとうございます。

titleは問題なく置換ができました。
ですが、answerが置換されずそのままとなっています。

何度も恐縮ですが、原因お分かりになりますでしょうか。

[jinoji]

置換前のtitleと値の組み合わせで辞書を見に行くので、
titleが置換されたあとだとanswerが置換できないことになります。
そういうことではないとしたら、ちょっとわかりません。

[退会済みユーザー]

詳細ありがとうございます。
いただいたコードを自身で確認してみます。