VBA マクロを使ってシート間で条件付きの転記をしていきたい

Question

エクセルのシート間の値の加算処理、スキップ処理を含めた転記処理についてです。
以下、画像のようにMacのエクセルで転記を実装したいです。
大学の課題で、以下を出されています。

転記の際の加算の方法、同列に同じ文字列が含まれるさいには処理を実行しないことなど、インターネットで調査をしたのですが、なかなかうまく書けませんでした。。

何卒、よろしくお願いします。

実現したいこと

このような手順で処理を行っていこうと考えています。
結果的に[転記先]のように転記したい。

担当者名を上から順番に「転記元」から転記していく、そのとき「担当者」というセルがある場合、担当者名が同列で重複する場合の2通りで処理をスキップします。

転記元シートで各担当者の右に入力されている数値をそのまま年月日に対応して転記していく。
K3のように、同じ担当者で「年月日」が重なっているときは重なった数値同士を加算する。

[質問１シート]1行目　セルに値がない
→無処理

[質問１シート]２行目　C列の値が「担当者」
→スキップ

[質問１シート]３行目　C列の値が「担当者名」
→[質問２シート]のC3に転記

[質問１シート] 21行目　C列の「担当者名」が３行目と重複
→担当者名は重複しているので無処理、「年月日」と数値部分は担当者Aに追記、この時数値が重なった場合は加算する

以降繰り返し

転記元

転記先

困っている事

下記のソースコード記載の①、②部分が特にわからずに困っています。
①同列に同じ担当者が含まれる際の条件の設定方法
②数値を転記していく際に重複している値同士をを加算する

他の部分でも、修正するべき箇所等ございましたら、修正してくださって構いませんので、サンプル等をいただけないでしょうか。

長くなってしまいましたが、何卒よろしくお願いいたします。

現在まで完成しているコード

Sub SheetTenki2()
Dim ec As Long               '年月の一番左から一番右までを取得
Dim lngFromRowsNo       As Long                     ' 検索する行位置
Dim lngToRowsNo         As Long                     ' 書きこむ行位置
Dim lngFromColumnNo       As Long                     ' 検索する列位置
Dim lngToColumnNo         As Long                     ' 書きこむ列位置
Dim wsFrom              As Worksheet                ' 取得側Excelシート
Dim wsTo                 As Worksheet                ' 設定側Excelシート
Dim ec1 As Long               ' 担当者列の一番下の担当者のセルを取得
Dim ec2 As Long               ' 各担当者の一番右の数値のセルを取得

'シート"質問１"を選択
    Sheets("質問１").Select
    
    lngFromRowsNo = 2
    
    ec1 = wsFrom.Cells(lngFromRowsNo, 3).End(xlDown).Row
    For lngFromRowsNo = 2 To .ec1
    
 ' 「担当者」以外の文字列が含まれるセルの値をC3から下に転記していく
 ' 転記していくとき、同じ担当者が含まれるときはスキップする（同じ担当者が記載されないようにする） ①
 If Not (Left(wsFrom.Cells(lngFromRowsNo, 3).Value, 3) = "担当者"  Or   '転記する列に同じ担当者が含まれるときという処理  ) Then

    GoTo NEXT99
    
 End If
 
  '担当者列に担当者を転記
 wsTo.Cells(ToRowNo, 3).Value = wsFrom.Cells(lngFromRowsNo, 3).Value
 
 '各担当者の右の数値を順に転記していく, −１としているのは一番右は「見込み合計」が入るから
 ec2 = wsTo.Cells(ToRowNo, 4).End(xlToRight).Column - 1
 lngToColumnNo = 4
 
 
  ' 転記元のD列から数値が存在するセルまで検索
 For lngFromColumnNo = 4 To .ec2
 
  ' 取得した数値を転記していく
   '数値を 転記していくときにセルが重複したら、その重複した数値同士を加算する②
 wsTo.Cells(ToRowNo, lngToColumnNo).Value = wsFrom.Cells(lngFromRowsNo, lngFromColumnNo).Value
 
  Next lngFromColumnNo
 
 ' １行下へ（転記先）
ToRowNo = ToRowNo + 1
    
NEXT99:
    
    Next lngFromRowsNo

End Sub

回答者様への追記

Comments

[meg_]

> ①同列に同じ担当者が含まれる際の条件の設定方法
配列を用意して、同じ担当者名がその配列内になければ追加する（＝新規担当者と判断）、とかどうでしょうか？

[icecleam]

ご質問ありがとうございます。
確かにその方がスマートですね。

その方法で実装できるのであれば、教えていただきたいです。
何卒よろしくお願いします

[meg_]

あれ？
> [質問１シート] 21行目　C列の「担当者名」が３行目と重複→スキップ
と
> K3のように、同じ担当者で「年月日」が重なっているときは重なった数値同士を加算する。
> ②数値を転記していく際に重複している値同士をを加算する
とは矛盾していませんか？

いづれにしても、
> ②数値を転記していく際に重複している値同士をを加算する
に関しては、質問のコードが書けるのであれば問題なく書けるかと思いますが。

[meg_]

> その方法で実装できるのであれば、教えていただきたいです。
配列の使い方が分からない、ということですか？
動的配列なら下記など分かりやすいかと思います。
http://officetanaka.net/excel/vba/variable/08.htm

[icecleam]

担当者はC列には重複した状態にはならずに、必ず一人という状況を作りたいです。
３行目でAはすでに転記できているので、２１行目では2020/10/1以降の数値のみの転記となります。
Aの2020/10/1は３行目でも転記元のK3で記載されており、２１行目ではD21で記載されているので、そういった場合にその値同士を加算したいという意味でした。

伝わりづらくてすみません。
内容をご理解いただけたでしょうか

[icecleam]

> K3のように、同じ担当者で「年月日」が重なっているときは重なった数値同士を加算する。
→同じ担当者で「年月日」が重なっているときは重なった担当者の「年月日」の数値同士を加算する。
ということですね。
質問内容も編集しました。

＞いづれにしても、
＞> ②数値を転記していく際に重複している値同士をを加算する
＞に関しては、質問のコードが書けるのであれば問題なく書けるかと思いますが。
すみません、上記のコードは自分で書いたのですが「重複している値同士をを加算する」部分の処理がわかりませんでした。。

[meg_]

では、下記の仕様提示が間違っていますね。”スキップ”だと何もしないことを意味しますので。
> > [質問１シート] 21行目　C列の「担当者名」が３行目と重複→スキップ

転記先のC列に同名の担当者が存在していれば、その人の該当する月に値を足していきたいわけですね。

[icecleam]

はい！その通りです！
失礼しました、修正しておきます。

[meg_]

> ①同列に同じ担当者が含まれる際の条件の設定方法

こちらについては、あるセル範囲にある値が存在するかどうかを調べる方法が分からない、ということでしょうか？　検索すれば情報は沢山ありますので調べましょう。

[icecleam]

そちらについては、長時間調べて色々試したのですが今回の場合に当てはまるようにソースを書くことができませんでしたので、こちらでご質問させていただきました。。
重なった値を加算する方も同様です。

[meg_]

もしかしたら、質問者さんは検索するのが苦手なのでしょうか？
「vba セル範囲 検索」で検索すると情報が見つかります。下記など良いかと思います。
http://officetanaka.net/excel/vba/tips/tips127.htm

[meg_]

> ②数値を転記していく際に重複している値同士をを加算する
こちらについては下記が参考になりそうです。
https://excel-ubara.com/excelvba1r/EXCELVBA504.html

[icecleam]

上記のリンクは両者とも見覚えがあります。
すみません、おそらくマクロはもちろんPG自体、初心者なため応用することに慣れていないのだと思います。。

調査を自分なりに進めた上での上記のコードになります。。

[kitasue]

icecleamさんは、ichijavaさんと同一人物なのでしょうか。
それとも、同じプロジェクトのメンバーですか？
あるいは、質問内容は何かの課題なのでしょうか。
以下と質問内容が同じです。
https://teratail.com/questions/295138
そこの私の回答も参考になさってください。

[icecleam]

すみません
そちらのリンクの方とは同一人物ではありません。
同じ課題に取り組んでいる方だと思われます。。

リンク先のkitasueさんのご回答なさっている内容を参照させて頂きました。

参考にさせていただいて、現在のコードの修正を試みたのですが（せっかくここまで書いたのなら自分のコードで目的を達成したいという私のわがままです、すみません）
参照設定がMacのエクセルであるためか、回答通りの設定が出来ずにうまく実行することができませんでした…
もし、ご迷惑でなければ上記の質問のコードを修正するような感じでご回答をいただければ幸いです。。
この業界の勉強を始めて日が浅いもので、知識が足りず的外れなことを書いているかもしれませんが、なにかあればおっしゃっていただけたらと思います。。

長文失礼いたしました。

[kitasue]

作成されたコードはMacで動かすのでしょうか。それともWindowsで動かすのでしょうか。

[icecleam]

Macで動かします。
記載するべきでしたね、すみません

[meg_]

> Macで動かします。
記載するべきでしたね、すみません
　⇒　質問に追記してください。

> 上記のリンクは両者とも見覚えがあります。
　⇒　「試したこと」の欄に調べたこと・参考にしたけどここが分からなかったこととして書いておいてください。回答者の時間の無駄になってしまいます。

> 同じ課題に取り組んでいる方だと思われます。。
　⇒　「課題」とは学校の課題ですか？　そのあたりも質問に追記するべきでしょう。kitasueさんのように「icecleamさんは、ichijavaさんと同一人物なのでしょうか。」思われると回答は付かないと思います。

私が紹介したリンクはかなり分かりやすい説明だと思いますが、Macだから動かなかったのでしょうか？
そこまでWindowsとMacでExcelVBAの動作って違いますか？

[tatsu99]

日付に関しての質問です。
1．yyyy/mm/ddのddの部分は１固定という前提で良いのでしょうか。（2020/1/2等はありえない）
2.転記元の日付は必ず転記先にも存在するという前提でよいのですか。
3.転記先の日付は、必ず、1月分ずつ日付が増えているという前提で良いですか。（月がとぶことはない）
4.質問1のシートの日付の列はD~L列固定で良いですか。（可変ではない）

[icecleam]

tatsu99さんへ
ご質問にお答えします
1.ddの部分は変わる可能性は考慮しなくて大丈夫です。
2.最大と最小で、値をとって1ヶ月毎に記載していくので、存在しない場合もあります。
3.月は飛ぶことはないので、その認識で問題ありません。
4.日付が存在する列までを考慮したいので、可変であるという認識でお願いします。

[icecleam]

megさんへ
質問内容の見直しと修正を実施しました。

Macであることは関係ないかもしれませんが、初心者なりにひとつの可能性として考えたものでした。
すみません、的外れな発言であったかもしれません。

[kitasue]

「見込み合計」の列は、[質問１]シートのすべての行で同じ列ですか？（サンプルではM列）

[kitasue]

丸投げの質問ではないと思いますよ。分からない部分は、書きようがないじゃないですか。

[icecleam]

kitasueさんへ
ご質問にお答えします。
いえ、[質問１]の見込み合計は年月日が下辺であるため、列が変化する可能性があります。
宜しくお願いします。

＞丸投げの質問ではないと思いますよ。分からない部分は、書きようがないじ＞ゃないですか。
フォローありがとうございます。。

Answer 1

tatsu99さんのDictionay版の回答を参考に、DictionaryをCollectionに変更してみました。
申し訳ありませんが、Mac上での動作確認はしていません。

Option Explicit

Const cnsWsh1RowBgn = 2
Const cnsWsh1Col担当者 = 3      'C列
Const cnsWsh1Col年月日 = 4      'D列
Const cnsWsh2Row年月日 = 2
Const cnsWsh2RowBgn = 3
Const cnsWsh2Col担当者 = 3      'C列
Const cnsWsh2Col年月日 = 4      'D列

Sub SheetTenki2()
    Dim lngWsh1Row As Long
    Dim lngWsh1RowEnd As Long
    Dim strWsh1担当者 As String
    Dim lngWsh1Col As Long
    Dim lngWsh2Row As Long
    Dim lngWsh2Col As Long
    Dim wsh1 As Worksheet
    Dim wsh2 As Worksheet
    Dim clcWsh2Row担当者 As Collection
    Dim var As Variant
    Dim lngCount As Long
    Dim varWsh1年月日 As Variant
    Dim i As Long
    
    Set wsh1 = Worksheets("質問1")
    Set wsh2 = Worksheets("質問2")
    Set clcWsh2Row担当者 = New Collection
    
'設定先消去

    wsh2.Range(wsh2.Cells(cnsWsh2RowBgn, cnsWsh2Col担当者), wsh2.Range("A1").SpecialCells(xlCellTypeLastCell)).ClearContents
        
'wsh2の担当者の行番号をCollectionに設定

    lngWsh1RowEnd = wsh1.Cells(wsh1.Rows.Count, cnsWsh1Col担当者).End(xlUp).Row
    For lngWsh1Row = cnsWsh1RowBgn To lngWsh1RowEnd
        If IsDate(wsh1.Cells(lngWsh1Row, cnsWsh1Col年月日).Value) = False Then
            strWsh1担当者 = wsh1.Cells(lngWsh1Row, cnsWsh1Col担当者).Value
            lngCount = clcWsh2Row担当者.Count
            lngWsh2Row = cnsWsh2RowBgn + lngCount
            On Error Resume Next
                clcWsh2Row担当者.Add Item:=lngWsh2Row, Key:=strWsh1担当者
            On Error GoTo 0
            If clcWsh2Row担当者.Count <> lngCount Then
                wsh2.Cells(lngWsh2Row, cnsWsh2Col担当者).Value = strWsh1担当者
            End If
        End If
    Next lngWsh1Row

'値の加算

    For lngWsh1Row = cnsWsh1RowBgn To lngWsh1RowEnd
        Select Case True
            Case IsDate(wsh1.Cells(lngWsh1Row, cnsWsh1Col年月日).Value)
                varWsh1年月日 = wsh1.Range(wsh1.Cells(lngWsh1Row, cnsWsh1Col年月日), wsh1.Cells(lngWsh1Row, wsh1.Columns.Count).End(xlToLeft)).Value
            Case Else
                strWsh1担当者 = wsh1.Cells(lngWsh1Row, cnsWsh1Col担当者).Value
                lngWsh2Row = clcWsh2Row担当者(strWsh1担当者)
                For i = LBound(varWsh1年月日, 2) To UBound(varWsh1年月日, 2)
                    If IsDate(varWsh1年月日(1, i)) Then
                        lngWsh2Col = DateDiff("m", wsh2.Cells(cnsWsh2Row年月日, cnsWsh2Col年月日).Value, varWsh1年月日(1, i)) + cnsWsh2Col年月日
                        var = wsh1.Cells(lngWsh1Row, cnsWsh1Col年月日 + i - 1).Value
                        Select Case True
                            Case var = ""
                            Case IsNumeric(var)
                                wsh2.Cells(lngWsh2Row, lngWsh2Col).Value = wsh2.Cells(lngWsh2Row, lngWsh2Col).Value + var
                        End Select
                    End If
                Next i
        End Select
    Next lngWsh1Row
        
    Set clcWsh2Row担当者 = Nothing
    Set wsh2 = Nothing
    Set wsh1 = Nothing
    
End Sub

Answer 2

"Scripting.Dictionary"を使わないバージョンです。
あまりデータが多いと遅くなるかも知れません。

Option Explicit
'Scripting.Dictionaryを使わないバージョン
Dim sh1 As Worksheet    '質問１シート
Dim sh2 As Worksheet    '質問２シート
Dim tan_names() As String   '担当者名を格納する文字列
Dim tan_count As Long       '担当者の数
Dim start_date As Variant   '質問２シートの開始日


Public Sub 転記2()
    Dim row1 As Long        '質問１シートの行番号
    Dim row2 As Long        '質問２シートの行番号
    Dim maxrow1 As Long     '質問１シート最大行
    Dim maxcol1 As Long     '質問１シートの個々の担当者行の最大列
    Dim val As String       '処理中の値
    Dim tan_row As Long     '担当者の行番号
    Call tan_init           '担当者テーブルクリア
    Set sh1 = Worksheets("質問1")
    Set sh2 = Worksheets("質問2")
    '質問２シートの３行目以降をクリア
    sh2.Rows("3:" & Rows.Count).ClearContents
    start_date = sh2.Range("D2").Value
    maxrow1 = sh1.Cells(Rows.Count, "C").End(xlUp).Row    '質問１シート C列 最終行を求める
    '質問１シートを２行から最終行まで繰り返す
    For row1 = 2 To maxrow1
        val = sh1.Cells(row1, "C").Value
        Select Case val
        Case ""             '無処理
        Case "担当者"
            maxcol1 = sh1.Cells(row1, Columns.Count).End(xlToLeft).Column   'この行の最終列を求める
            tan_row = row1     'この行を記憶（担当者の行）
        Case Else           '上記以外（個々の担当者）
            '担当者テーブルを検索し、その要素番号を取得する。先頭が１なので、＋２すると質問２シートの行番号になる
            row2 = tan_find(val) + 2
            sh2.Cells(row2, "C").Value = val
            Call atai_tenki(row1, row2, tan_row, maxcol1)  '質問２シートへの転記
        End Select
    Next
    MsgBox ("完了")
End Sub
    '個々の担当者の処理
Private Sub atai_tenki(ByVal row1 As Long, ByVal row2 As Long, ByVal tan_row As Long, ByVal maxcol1 As Long)
    Dim wcol2 As Long   '質問２シートの加算先の列
    Dim wdate As Variant    '日付
    Dim sabun As Long       '月の差（質問２シートの開始月と処理月の差）
    Dim wcol1 As Long   '質問１シートの処理中の列
    '当該行の４列から最終列の１つ前まで繰り返す
    For wcol1 = 4 To maxcol1 - 1
        'この列の日付を取得
        wdate = sh1.Cells(tan_row, wcol1)
        '取得した日付が質問２シートのどの位置にあるか算出する
        sabun = DateDiff("m", start_date, wdate)
        wcol2 = 4 + sabun
        '数値が設定されているなら、質問２シートの該当月に加算する
        If sh1.Cells(row1, wcol1).Value <> "" And IsNumeric(sh1.Cells(row1, wcol1).Value) = True Then
            sh2.Cells(row2, wcol2).Value = sh2.Cells(row2, wcol2).Value + sh1.Cells(row1, wcol1).Value
        End If
    Next
End Sub


'担当者テーブル初期化
Private Sub tan_init()
    tan_count = 0
    ReDim tan_nems(tan_count)
End Sub

'指定された名前で担当者テーブルを検索し、その要素の番号を返す（1以上の値）
'存在しない場合は、テーブルに追加し、その要素の番号を返す
Private Function tan_find(ByVal name As String) As Long
    Dim i As Long
    'tan_namesテーブルをnemeで検索　先頭（0）は使用しない
    For i = 1 To tan_count
        '存在すれば、その要素番号を返す
        If tan_names(i) = name Then
            tan_find = i
            Exit Function
        End If
    Next
    '存在しない場合、nameを追加する
    tan_count = tan_count + 1
    ReDim Preserve tan_names(tan_count)
    tan_names(tan_count) = name
    tan_find = tan_count
End Function

Comments

[icecleam]

ありがとうございます！
上記のコードで実装することができました！

[icecleam]

すみません
補足でご質問したいことがあります。
以下の２行では具体的にどのような処理を行っているのでしょうか。
ご迷惑でなければ教えていただきたいです。。
----
wcol2 = sabun + 4
-----

-----
tan_find = tan_count
-----

[tatsu99]

wcol2は質問２シートへ設定する列の番号です。
2020/3/1がD列なので番号は４になります。
2020/3/1なら4
2020/4/1なら5
2020/5/1なら6
のようになれば良いわけです。
もし、質問１シートの日付が2020/6/1なら、sabun（月の差）は３なので
wcol2=3+4　となり結果は７になります。よって、G列が設定する列となります。
次に、tan_find = tan_countですが、
tan_find=XXXとすると、tan_findが呼び出し元へ返す値を設定します。
最初の１件目（担当者＝A）は、tan_names内にないので、tan_count=1となり
tan_find=tab_countが実行されるので、呼び出し元に1が返ります。
次の２件目（担当者＝C）は、同様に呼び出し元に2が返ります。
質問１シートの21行の担当者＝Aの場合は、既にtan_names内に存在するので、
tan_find = i
Exit Function
が、実行されます。この時iは１なので、呼び出し元に１が返ります。

[icecleam]

ありがとうございます！

重ね重ね申し訳ないのですが、もう一つご質問があります。。

今回「Option Explicit」を使用したマクロになっていると思うのですが、「Option Explicit」を使わない形に修正したい時、全体はどのように修正すれば良いのでしょうか。
教えていただければ幸いです。。

[tatsu99]

単純にOption Explicitを削除すれば良いだけです。
但し、個人的には、Option Explicitを使用することを推奨します。
想像ですが、私の提示したマクロとほかのマクロを１つのmoduleに格納しようとされていると理解しました。ほかのマクロがOption Explicitを使用していないので、変数が未定義のエラーがでているのだと思います。その場合、変数 xxxが未定義なら
dim xxx
と宣言すれば、エラーはなくなりますので、そのようにしてください。
本来なら
dim xxx as Longとかdim xxx as Stringとか型を明確に指定する方が良いのですが、型が判らない場合は
dim xxx でもエラーはとれますので、そのようにしてください。

[icecleam]

ありがとうございます
すみません、モジュールをまとめようとしているわけではなく、課題のルールとしてOption Explicitは使ってはいけなかったみたいで。。

今、Option Explicitを削除して正常に動くことは確認したのですが、以下の宣言部分は「Public Sub 転記2()」の上にそのまま存在する形で問題ないのでしょうか。
Option Explicitを消すだけという簡単な対応だけで済んでしまって、なんか不安になってしまいました。。

Dim sh1 As Worksheet '質問１シート
Dim sh2 As Worksheet '質問２シート
Dim tan_names() As String '担当者名を格納する文字列
Dim tan_count As Long '担当者の数
Dim start_date As Variant '質問２シートの開始日

[tatsu99]

Option Explicitの意味は、変数を定義しないでいきなり使用した場合、それをエラーにするという機能です。
従って、Option Explicitが宣言されて正常に実行できるものは、当然、Option Explicitをなくしても正常に実行できます。
Dim sh1 As Worksheet '質問１シート（以降省略）の部分は、
各プロシージャ（Public Sub 転記2、Private Function tan_find等）の外側で宣言されています。
これは、どのプロシージャからも参照／更新が可能という意味です。
従って、Public Sub 転記2()の外側で定義します。（Public Sub 転記2()の中で定義するとPrivate Sub atai_tenkiから参照できなくなるのエラーになります）

[icecleam]

Option Explicitとはそういう意味だったのですね
それでは上記でご回答いただいた、コードのOption Explicit部分を消しただけのコードでも、正常なコードと言えるということですね。

ご回答いただきありがとうございます

Answer 3

前提として質問１シートに記述されている日付は質問２シートの最小日付～最大日付の範囲内にあるという前提です。範囲内にないと、マクロが暴走します。例として2018/1/1がもし、質問１シートにあるとマクロが暴走します。
以下のマクロを標準モジュールに設定してください。
windowsでのみ確認しています。あなたの環境で正常に動作しない場合は、その旨補足してください。
その原因がmac由来なら、お手上げですが、excelのレイアウトの齟齬等であれば、解決可能かも知れません。

Option Explicit

Dim sh1 As Worksheet    '質問１シート
Dim sh2 As Worksheet    '質問２シート
Dim dicT As Object      '連想配列   キー：担当者名　値：質問２シートの行番号
Dim start_date As Variant   '質問２シートの開始日


Public Sub 転記()
    Dim row1 As Long
    Dim maxrow1 As Long     '質問１シート最大行
    Dim maxrow2 As Long     '質問２シート最大行
    Dim maxcol1 As Long     '質問１シートの個々の担当者行の最大列
    Dim val As String       '処理中の値
    Dim tan_row As Long     '担当者の行番号
    Set dicT = CreateObject("Scripting.Dictionary")    ' 連想配列の定義
    Set sh1 = Worksheets("質問1")
    Set sh2 = Worksheets("質問2")
    '質問２シートの３行目以降をクリア
    sh2.Rows("3:" & Rows.Count).ClearContents
    start_date = sh2.Range("D2").Value
    maxrow1 = sh1.Cells(Rows.Count, "C").End(xlUp).Row    '質問１シート C列 最終行を求める
    maxrow2 = 3     '質問２シートの担当者の開始行
    '質問１シートを２行から最終行まで繰り返す
    For row1 = 2 To maxrow1
        val = sh1.Cells(row1, "C").Value
        Select Case val
        Case ""             '無処理
        Case "担当者"
            maxcol1 = sh1.Cells(row1, Columns.Count).End(xlToLeft).Column   'この行の最終列を求める
            tan_row = row1     'この行を記憶（担当者の行）
        Case Else           '上記以外（個々の担当者）
            If dicT.Exists(val) = False Then
                '最初の出現時、担当者に割り当てた質問２シートの行番号を記憶する
                dicT(val) = maxrow2
                sh2.Cells(maxrow2, "C").Value = val
                maxrow2 = maxrow2 + 1
            End If
            Call atai_tenki(val, row1, tan_row, maxcol1)   '質問２シートへの転記
        End Select
    Next
    MsgBox ("完了")
End Sub
    '個々の担当者の処理
Private Sub atai_tenki(ByVal tan_name As String, ByVal row1 As Long, ByVal tan_row As Long, ByVal maxcol1 As Long)
    Dim wrow2 As Long   '質問２シートの加算先の行
    Dim wcol2 As Long   '質問２シートの加算先の列
    Dim wdate As Variant    '日付
    Dim sabun As Long       '月の差（質問２シートの開始月と処理月の差）
    Dim wcol1 As Long   '質問１シートの処理中の列
    wrow2 = dicT(tan_name)  '担当者に割り当てられた質問２シートの行番号を取得
    '当該行の４列から最終列の１つ前まで繰り返す
    For wcol1 = 4 To maxcol1 - 1
        'この列の日付を取得
        wdate = sh1.Cells(tan_row, wcol1)
        '取得した日付が質問２シートのどの位置にあるか算出する
        sabun = DateDiff("m", start_date, wdate)
        wcol2 = 4 + sabun
        '数値が設定されているなら、質問２シートの該当月に加算する
        If sh1.Cells(row1, wcol1).Value <> "" And IsNumeric(sh1.Cells(row1, wcol1).Value) = True Then
            sh2.Cells(wrow2, wcol2).Value = sh2.Cells(wrow2, wcol2).Value + sh1.Cells(row1, wcol1).Value
        End If
    Next
End Sub

Comments

[icecleam]

ご回答いただきありがとうございます！

上記のコードを実行したら
エラーメッセージ「ActiveXコンポーネントはオブジェクトを作成できません」と出てしまうのですが、どうすれば良いでしょうか。。

また、以下のマクロを標準モジュールに設定
というのは普通のマクロと同様に実行することと何か違いはあるのでしょうか

質問が多くてすみませんがお答えいただければと思います。。

[tatsu99]

windowsのexcel2007ですが、標準モジュールの図を追加しました。macにこのような個所はないのでしょうか。
「ActiveXコンポーネントはオブジェクトを作成できません」は、マクロのどの行で発生しますか？

[icecleam]

今、質問に画像を追加しましたのでご確認ください。

＞「ActiveXコンポーネントはオブジェクトを作成できません」は、マクロの＞どの行で発生しますか？
デバッグをした際に、以下で止まっていました。
---
Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義
----

すみませんが、ご確認いただければと思います。
宜しくお願いします

[tatsu99]

すみません。下記URLをみるとmacでは"Scripting.Dictionary"が使えないみたいですね。
https://nandakagoodvibes.hatenablog.com/entry/2019/05/26/150806
提示したマクロはmacでは使えないので、このマクロは取り下げます。

[icecleam]

ですね、私も今ちょうど同じような内容の記事を見つけたところでした。。
せっかくご回答いただいたのに申し訳ありません。

引き続きご回答はいただけたりしますでしょうか。。

[tatsu99]

もう少し、本当に使えないのか調べてみます。本当に使えない場合は、"Scripting.Dictionary"を使わない方法を検討してみます。

[icecleam]

ありがとうございます。。
当然ではありますが、こちらでも調査を進め、回答が見つかり次第こちらでご連絡させていただきます。

補足
こちらでも調べた感じだと、"Scripting.Dictionary"はやはりMACでは使えない線が強そうです。。