出力時、新しいシートが追加されるがデータが出力されない

Question

※サンプルデータとして画像を追加しました。

以下を実現するプログラムを作りたいと考えております。
しかし、表題が原因で実現できずにいます。

【プログラムコードについての説明】
Excelから取得してきたデータを一旦、extractedDataにぶち込み、
extractedDataから条件処理をしたデータを、
連想配列と2次元配列へぶち込んでいます。
2つの配列を作っているので、
主キーと外部キーを作っています。

【extractedDataのサンプルデータ】

【以下コード】

Sub DuplicateCalculation()

Dim lineNum As Integer
    lineNum = WorksheetFunction.CountA(Range("A4", Range("A" & Rows.Count)))


    'データをExcelから取得
    ReDim extractedData(1 To lineNum, 1 To 14) As Variant
    ReDim Preserve extractedData(1 To lineNum, 1 To 14) As Variant

    Dim i, j, c
    For j = 1 To lineNum
        c = 1
        For i = 1 To 15     'A列～O列まで
            If i <> 3 Then  'C列以外
                extractedData(j, c) = Cells(j + 3, i)
                c = c + 1
            End If
        Next
    Next




    '取得してきたデータを条件処理
    Dim areaName As Object
    Set areaName = CreateObject("Scripting.Dictionary")
    Dim feeValue() As Variant

    'B列とD列～O列の動的配列の入れ物作成
    ReDim Preserve feeValue(1 To j, 1 To i)


     k = 1 'kはキー変数
       For j = 1 To lineNum

            'キーがまだ存在してないのなら値を配列に追加/常にキー列(A列)を取得するので列固定
            If Not areaName.Exists(extractedData(k, 1)) Then
                'A列を配列に追加
                '値が重複→その時のindexNumberのitemは空のままだから重複回数分をマイナス
                areaName.Add extractedData(k, 1), k

                'B列追加、D列～O列追加
                r = 1
                For m = 2 To 13
                    feeValue(j, r) = extractedData(k, m)
                    r = r + 1
                Next
            Else
                'キーが既に存在しているならここのルートを通る
                    '売上を合算
                    For a = 1 To 12
                    'a = 2のとき、合算しないが重複データは削除
                        If a = 1 Then
                            feeValue(areaName.Count, a) = extractedData(k, a + 1)
                            Else
                                '元の位置にあるデータ＋重複している行の列の値。
                                feeValue(areaName.Count, a + 1) = extractedData(areaName.Count, a + 1) + extractedData(k, a + 1)
                        End If
                    Next
            End If
            k = k + 1
        Next


    '新規シートを名前を変更してシートの最後尾に挿入
    Dim NewWorkSheet As Worksheet
    Set NewWorkSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    NewWorkSheet.Name = "Sheet2"


    'リストを出力 areaNameの値とfeeValueの値をキーで対応させて出力する
    For j = 1 To UBound(areaName.keys)
        For i = 1 To 14
            NewWorkSheet.Cells(j + 4, i).Value = areaName.Item(i)
            NewWorkSheet.Cells(j + 4, i + 1).Value = feeValue(j, i)
       Next
    Next


End Sub

Comments

[Usirow]

ご本人としては地続きの内容だと思うのですが、これでは「Dictionaryに値が入らない」というもともとの質問内容が消えてなくなってしまっているので、別の質問として分離した方が良くはないでしょうか。

[YAmaGNZ]

質問が完全に変わってしまっています。
別質問として分けるべきです。

Answer 1

実はこんな感じでいけるのかもしれない。

Sub sample1()
    
    '元シートから地域名、地域コードを取得
    Dim ws As Worksheet, rng As Range
    Set ws = Worksheets(1)
    Set rng = ws.Range(ws.Range("A4"), ws.Cells(ws.Rows.Count, 1)).Resize(, 2)
    
    '新シートに貼り付け、重複を削除
    Dim newSheet As Worksheet
    Set newSheet = Worksheets.Add(After:=ws)
    rng.Copy Destination:=newSheet.Cells(1, 1)
    newSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo
    
    '地域名ごとに売上金額を合算する数式をセット
    Dim wFormula
    wFormula = Replace("=SUMIF(Sheet1!$A:$A,$A1,Sheet1!D:D)", "Sheet1", ws.Name)
    newSheet.UsedRange.Offset(, 2).Resize(, 13).Formula = wFormula
    
    '計算結果を値で再セット
    newSheet.UsedRange.Value = newSheet.UsedRange.Value

End Sub

---

（追記前）

Sub sample()

    Dim lineNum As Integer
    lineNum = WorksheetFunction.CountA(Range("A4", Range("A" & Rows.Count)))

    'データをExcelから取得
    ReDim extractedData(1 To lineNum, 1 To 14) As Variant
    ReDim Preserve extractedData(1 To lineNum, 1 To 14) As Variant

    Dim i, j, c
    For j = 1 To lineNum
        c = 1
        For i = 1 To 15     'A列～O列まで
            If i <> 3 Then  'C列以外
                extractedData(j, c) = Cells(j + 3, i)
                c = c + 1
            End If
        Next
    Next
    
    '取得してきたデータを条件処理
    Dim areaDic 'As Scripting.Dictionary
    Set areaDic = CreateObject("Scripting.Dictionary")
    
    Dim areaName, fees As Variant, dicData As Variant
    
    For j = 1 To lineNum
        areaName = extractedData(j, 1)
        fees = WorksheetFunction.Index(extractedData, j, 0)
        
        If Not areaDic.Exists(areaName) Then
            areaDic.Add areaName, fees
        Else
            dicData = areaDic(areaName)
            For i = 3 To UBound(fees)
                fees(i) = fees(i) + dicData(i)
            Next
            areaDic(areaName) = fees
        End If
    Next
    
    '新規シートを名前を変更してシートの最後尾に挿入
    With Worksheets.Add(After:=Worksheets(Worksheets.Count))
        .Cells.Resize(areaDic.Count, 14).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(areaDic.Items))
        .Name = "Sheet2"
    End With

End Sub

Answer 2

            If Not areaName.Exists(extractedData(k, 1)) Then
                'A列を配列に追加
                '値が重複→その時のindexNumberのitemは空のままだから重複回数分をマイナス
                areaName.Add extractedData(k - d, 1), k - d

とりあえず上記のロジックがおかしいのでは？

Not areaName.Exists(extractedData(k, 1))でキーが存在しないのを確認しているので、そのキーを追加することになるはずので、下記でいいはずです。
k - d して別のキーを追加したらすでに存在しいると怒られるのは当然です。

            If Not areaName.Exists(extractedData(k, 1)) Then
                'キーが損斬しない→そのキーと
                areaName.Add extractedData(k, 1), k

ざっとしか見てませんが他にもいろいろおかしいところがありそうです。

---

たぶん下記のようなことをしたいのかな。

A列B列は重複を排除、D列以降はA例の値が同じもので合計

Public Sub Test()
    Dim lastLine As Integer
    lastLine = Cells(Rows.Count, "A").End(xlUp).Row

    Dim sourceData() As Variant
    sourceData = Range("A1:O" & lastLine).Value 'データ範囲を配列に格納（C列含む）
    
    
    Dim areaName As Object
    Set areaName = CreateObject("Scripting.Dictionary")
    
    Dim outoutData()
    ReDim outoutData(1 To lastLine, 1 To 14) '出力用配列 サイズは大きめにとっておく
    
    
    Dim r As Long, c As Long, r2 As Long
    
    For r = 1 To UBound(sourceData)
        If areaName.Exists(sourceData(r, 1)) Then
            Dim r3 As Long
            r3 = areaName(sourceData(r, 1))
            
            outoutData(r3, 2) = sourceData(r, 2)
        
            '重複していたら出力配列に加算(D列以降)
            For c = 3 To 14
                 outoutData(r3, c) = outoutData(r3, c) + sourceData(r, c + 1)
            Next
        Else
            '重複していなければキー(A列の値)とアイテム(出力先行番号)を追加
            r2 = r2 + 1
            areaName.Add sourceData(r, 1), r2
            
            outoutData(r2, 1) = sourceData(r, 1)
            outoutData(r2, 2) = sourceData(r, 2)
            For c = 3 To 14
                 outoutData(r2, c) = sourceData(r, c + 1)
            Next
        End If
    Next
    
        '新規シートを名前を変更してシートの最後尾に挿入
    Dim NewWorkSheet As Worksheet
    Set NewWorkSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    NewWorkSheet.Name = "Sheet2"

    NewWorkSheet.Cells(4, 2).Resize(r2, 14).Value = outoutData
End Sub

解説

まずは、下記の点を理解しましょう。
セル範囲（Rangeオプジェクト）は Valueプロパティで配列として取得できます。
また、配列をセル範囲のValueに代入することで一気に入力できます。
コードがシンプルになるし高速化するというメリットもあります。

Office TANAKA - VBA高速化テクニック[配列を使う]

処理の流れとしては、

Valueでデータ範囲を配列に格納。sourceData

出力用配列は最大サイズで生成しておく。（sourceDataの行数と同じにする。）

データ配列を1行目から最終行までForループで走査。
　キーが既に存在していたら、
　　　出力先配列の値にデータ配列の現在行の値を加算。
　キーが存在しない場合は、
　　配列の1列目の値をDictionaryのキーとして追加、アイテムは出力先行番号。
　  出力先配列にデータ配列の現在行の値を転記。
ループ終了

シートを追加して、そこに出力配列をセル範囲のValueに出力。

Comments

[退会済みユーザー]

※サンプルデータとして画像を追加しました。
例えば、k=3の時、
データが重複しており、
If Not areaName.Exists(extractedData(k, 1)) Then
の直下にある処理内容を通りません。
であれば、当然、
areaNameの連想配列にはk=3の時の値が入らない事になります。
ここまではわかりますか。
そうなると、Else以下の文に通る事になります。
Else以下の文で重複している時の処理を終えると、
End Ifに辿り着き、kが加算されます。
この時のkの値はk=4です。
そして、重複チェックに戻ります。

すると、k=3の時、
areaName.Add extractedData
が行われていない為、空白になりえませんか。

[退会済みユーザー]

編集された返信内容について
試験的にそちらが作って頂いたコードを使わせて頂きました。
私がしたい事をまさに実現できておりました。
しかし、せっかくお作り頂いたのに大変恐れ入りますが
学びにならないので詳しくコードを追っておりません。
ただ、
作って頂いたコードのポイントを教えて頂きたいです。

[hatena19]

コードの意味はコメントで説明しています。

全般的な解説を回答に追記しておきますので参照ください。

[退会済みユーザー]

解説も含めたコードの中で、
1点だけ、質問があります。
重複分岐処理において、
重複していた場合のコードにある
outoutData(r3, 2) = sourceData(r, 2)
これはどの様な意図があるのでしょうか。

コードについて、
キーを渡してアイテムを返す事でその行番号を元々あったデータとして扱える。
2つの条件分岐にそれぞれ条件用の行番号変数として
r2,r3を設ける事でズレなく
元々あったデータの位置を示す事ができるという発想ができませんでした…
また、Rangeなどによる範囲指定で自動的に配列にかわる事は知りませんでした。
ありがとうございます

[hatena19]

If文のコードは下記のようなことをしています。

重複していた場合 =すでに同じキーがある＝ areaName.Exists がTrue の時、
outoutData(r3, c) = outoutData(r3, c) + sourceData(r, c + 1)
出力先配列の各列の値にデータ配列の値を加算する(r3は出力先行番号)

Else ＝ 重複していないとき、
DictionaryオブジェクトにA列の値をキー、出力先行番号をアイテムとして追加する。
出力先配列の各列の値にデータ配列の値を代入する。

[退会済みユーザー]

勿論、動きに関しては存じております。
私が言いたいのは動きではなくそのコードを記載した意図でして、
重複していない時はElse以下の文を通ります。
重複している時はIf直下の文を通ります。
重複している時は既にデータが挿入されているので、
outoutData(r3, 2) = sourceData(r, 2)
これを記述する事で同じ値を上書き？のようなカタチになりませんか。

[hatena19]

重複しているとき、つまり、すでにそのキーはDictionaryに存在しているので、
キーからアイテム(出力先行番号)を取得　r3 = areaName(sourceData(r, 1))
その出力先の値にsourceDataの値を加算して、上書きする。
outoutData(r3, c) = outoutData(r3, c) + sourceData(r, c + 1)

単なる上書きではなく、集計するために加算して上書きしているということです。

Answer 3

エラーに関しては

A,1
B,2
C,3
A,2
D,4
とデータがあった場合、D,4のデータを処理する時（k=5）
extractedData(k, 1)はDなのでDictionaryにはキーが存在しないことになります。
Aが重複しているのでdは加算され1となっているはずです。
そしてAddする時にdを引き算するとk - d = 4となりAをAddしようとします。
そうするとすでにDictionaryにはAのキーが存在しますから「このキーは既にこのコレクションの要素に割り当てられています」とエラーになります。
なぜAddする時にextractedData(k - d, 1)と重複した回数を引いているのでしょうか？

また

それとは別に空白だった値にデータを入れたいので

dという重複回数を示す変数を定義したものの、
初期値は0なので、
初めて重複したデータに出会った時は、
何の意味も持たない変数になってしまいます。

とのことですが、こちらもどのような意図があるのか私には読み取れませんでした。

例でいいので入力データと出力データがあったほうが意図が伝わりやすいかと思います。

追記

areaName.Add extractedData

が行われていない為、空白になりえませんか。

Dictionaryについて勘違いされているようです。

上記のように
A,1
B,2
C,3
A,2
とデータがあった場合、areaNameは
A,1
B,2
C,3
とAddされたデータしか格納されていませんのでk=4の時に何もAddしていない場合はareaNameは3件と変化しません。
なので空白データは存在しません。
重複したデータをただ処理したくないだけであれば

       For j = 1 To lineNum

            'キーがまだ存在してないのなら値を配列に追加/常にキー列(A列)を取得するので列固定
            If Not areaName.Exists(extractedData(k, 1)) Then
                'A列を配列に追加
                '値が重複→その時のindexNumberのitemは空のままだから重複回数分をマイナス
                areaName.Add extractedData(k , 1), k 

            End If
            k = k + 1
        Next

といった感じで処理しなければいいだけです。
（他の部分の処理に関しては見ていません）

Comments

[退会済みユーザー]

質問文章を修正させて頂きました。

例えば、k=3の時、
データが重複しており、
If Not areaName.Exists(extractedData(k, 1)) Then
の直下にある処理内容を通りません。
であれば、当然、
areaNameの連想配列にはk=3の時の値が入らない事になります。
そうなると、Else以下の文に通る事になります。
Else以下の文で重複している時の処理を終えると、
End Ifに辿り着き、kが加算されます。
この時のkの値はk=4です。
そして、重複チェックに戻ります。

すると、k=3の時、
areaName.Add extractedData
が行われていない為、空白になりえませんか。

ちなみに、
dを用いずに出力した結果、
都道府県のみのデータがズラズラと並び、
期待した結果が得られませんでした。
また、出力時にkeyではなくitemを指定してみると
歯抜けのデータになっており、
重複時の処理の時のkの値のデータだけ抜けておりました。
この事からdという別の変数を定義する必要があると考え、
上記プログラムを作るに至りました。

[退会済みユーザー]

追記について
Dictionaryについて、勘違いしていたようです。
ありがとうございます。
となれば、問題があるのは出力のほうですね。

[YAmaGNZ]

多分、データを格納するfeeValueが間違っていると思います。
重複した場合にareaNameの数が変動しないのでfeeValueで格納されている場所とずれが発生するのでしょう。
feeValueに格納する時にareaName.Countを利用するといいかもしれません。

[退会済みユーザー]

頂いた情報をもとにコードに反映し、
私が今記載している質問文のコードを編集して反映させました。
しかしながら、
今度は全くの空白でした。
先ほどのお答えして頂いた内容について、
.Countというペア数の取得を使う、なんて私には盲点でした…
ありがとうございます。