エクセル、マクロ《クロス集計を複数シートに》

Question

###実現したい事
マクロを使ってデータを取込、二つの条件が一致したらクロスしたセルに取り込んだデータから指定した値を入れ込むというマクロを作成しようとしています。

###イメージ

取り込まれる側【データ1】

取り込む側【データ２】(複数シート)
１

２

３

４

５

###要件
データ１を取り込んだ時に、
データ2-1（シート名:関東）のC1セルとデータ1のA１セル、
データ2-1のA3セルとデータ1のC1セル
が一致した際にデータ2-1のC3セルに2500と入れる
一致する箇所が見つかるまですべてのシートで同じ動作を繰り返し、一致する場所がない場合は次の項目に行く、
そのようなマクロを作成したいのですが、皆さまならどのようなソースで作成しますか？
自分でソースを書く前からの質問で恐縮ですが、お時間のある方お助けください。

###補足情報(言語/FW/ツール等のバージョンなど)
データ２のシートをご覧いただくとエリアごとに分けてありますが、
このエリアごとに、作成されたシートをメールで送る機能もつけたいと考えています。
よろしくお願いします。

Answer 1

自分でソースを書く前からの質問で恐縮ですが、お時間のある方お助けください。

これだといわゆる丸投げになってしまいます。
少しでも自力で努力してから質問したほうがいいですよ。

着手するための手助けとして、以下に（穴だらけの）コードを提示します。
やらなければならないことはコメントとして記載しています。
参考までに。

Sub Torikomi()
    
    Dim wsData as WorkSheet
    Dim wsOut as WorkSheet
    
    Dim iRow as Integer
    Dim iOutRow as Integer
    Dim iOutCol as Integer
    
    'データシートを設定
    Set wsData = Workbooks("取り込まれる側.xlsx").Sheets("Sheet1")
    
    iRow = 1
    
    'データシートを１行目からデータがなくなるまでループ処理
    Do 
        'データシートの現在行・G列から地方を設定
        Dim strLocalNm as String
        Select Case wsData.Cells(iRow, 7) 
            Case "東京"
                strLocalNm = "関東"
            Case Else
                strLocalNm = "地方シート名"
        End Select
        Set wsOut = ThisWorkBook.Sheets(strLocal)
        
        '出力位置の初期化
        iOutCol = 0
        iOutRow = 0
        
        'データシートの対象行・A列のセルの値を、地方シートの1行目から検索。一致する列番号を記憶する。
        iOutCol = 見つけた列番号
        
        'データシートの対象行・C列のセルの値を、地方シートのC列から検索。一致する行番号を記憶する。
        iOutRow = 見つけた行番号
        
        '列・行ともに見つかった場合、データシートの現在行・E列を地方シートに出力
        If iOutCol > 0 And iOutRow > 0 Then
            wsOut.Cells(iOutRow, iOutCol) = wsData.Cells()
        End If
        
        'データシートの行を１つ進める
        iRow = iRow + 1
    Loop
End Sub

Comments

[teryyyyy2]

ご回答ありがとうございます。
自分でも作っているところなのですが自分の要件定義が言葉足らずでした。
```
Option Explicit

Dim gyo As Long
Dim gyo2 As Long
Dim gyo3 As Long
Dim filecount As Long
Dim sheetcount As Long
Dim unmatch As Long
Dim erfilecount As Long
'ボタンを押したとき
Sub FolderSelect()
'ThisWorkbook.Worksheets(1).Range("A6:C3005").ClearContents
'ThisWorkbook.Worksheets(2).Range("B1:BE3005").ClearContents
Dim folderpass As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
folderpass = .SelectedItems(1)
Else
ThisWorkbook.Worksheets(1).Range("B3").Value = "キャンセルしました。"
Exit Sub
End If
End With

filecount = 0
sheetcount = 0
unmatch = 0
erfilecount = 0
gyo = 6
gyo2 = 2
gyo3 = 2

ThisWorkbook.Worksheets(1).Range("B2").Value = "処理中"

Call FileSearch(folderpass, "*.csv")
Dim dateupdate As String
dateupdate = Year(Date) & "年" & Month(Date) & "月" & Day(Date) & "日更新"
'ThisWorkbook.Worksheets(2).Range("A1").Value = dateupdate
'ThisWorkbook.Worksheets(2).Name = dateupdate '
ThisWorkbook.Worksheets(1).Range("B2").Value = "完了"
ThisWorkbook.Worksheets(2).Activate
End Sub
'ファイル検索
Sub FileSearch(Path As String, Target As String)
Dim FSO As Object, Folder As Variant, File As Variant
Set FSO = CreateObject("Scripting.FileSystemObject")
For Each Folder In FSO.GetFolder(Path).SubFolders
Call FileSearch(Folder.Path, Target)
Next Folder
For Each File In FSO.GetFolder(Path).Files
If File.Name Like Target Then
filecount = filecount + 1
ThisWorkbook.Worksheets(1).Cells(gyo, 1) = File.Name
ThisWorkbook.Worksheets(1).Cells(gyo, 2) = File.Path
Call ParCopy(File.Path)
gyo = gyo + 1
End If
ThisWorkbook.Worksheets(1).Range("B3").Value = filecount & "個のファイルが見つかりました。"
Next File
End Sub
''一覧出力
Sub ParCopy(Path As String)

Dim openbook As Workbook
Dim openbooksheet As Worksheet
Dim lp As Long
Dim el As Long
Dim br As String
'オ
Dim c As Range, Target As Range
Dim LastRow As Long
'縦軸(マクロ側シート数用)
lp = 5
'横軸(データ側ループ管理用)
el = 3

Application.ScreenUpdating = False

On Error GoTo myError
Set openbook = Application.Workbooks.Open(Path)

Set openbooksheet = openbook.Worksheets(1)
openbooksheet.Unprotect

Do Until lp = 31

Do Until Cells(el, 1) = ""

br = ThisWorkbook.Worksheets(lp).Cells(el, 2)

Selection.AutoFilter
openbooksheet.Range("A1").AutoFilter Field:=8, Criteria1:=br

LastRow = Cells(Rows.Count, 1).End(xlUp).Row

openbooksheet.Range("J2:J" & LastRow).Copy ThisWorkbook.Worksheets(lp).Range("el3")
openbooksheet.Range("A1").AutoFilter

Range("A2", Cells(Rows.Count, 1).End(xlUp)).Select
el = 1

Loop

lp = lp + 1
Loop

openbook.Close False

Application.ScreenUpdating = True
Exit Sub
myError:
MsgBox Err.Description
ThisWorkbook.Worksheets(1).Cells(gyo, 3) = "エラー発生"
erfilecount = erfilecount + 1
Application.ScreenUpdating = True
End Sub
```

エリア分けしたフォーマットは作成してあり、
フォーマットのこの例でいえば取り込む側の"ハイステ"
で取り込まれる側のデータをフィルタし、列ごとコピーして貼り付ける
という動作を全シート分繰り返すというマクロを作りたいのです。
今なぜか動かず戦っているとこではありますが笑

[teryyyyy2]

質問内容がうまくまとまっていなかったので質問自体を上げなおしたいと思います。
よろしければまたお力をお貸しください。

Answer 2

う～ん、私なら大きな括りとしてはシート単位ですかね。（九州・四国・中国が何で無いのか？は気になるところですが・・・）
シートが関西や関東などの地方になってるので、各地方に含まれる都道府県でまず抽出してから書き出すことになるかと。