2024-03-07

【ﾉｰｺｰﾄﾞVBA】複数シートから、同一セルの値を抽出し、一覧表に転記する（預り金残高一覧）

エクセルVBAマクロを自動作成する無料アプリです。

例として「複数シートから、同一セルの値を抽出し、預り金残高一覧表に転記する」VBAマクロを作成します。

事例　預り金残高一覧を作成
ChatGPTで修正
アプリはこちらから↓↓↓↓

事例　預り金残高一覧を作成

マクロを実行すると、原本を除いたすべてのシートデータが転記されました。

アプリの設定

アプリへのリンク
　⇒複数シートから、同一セルの値を抽出し、一覧表にする

【ポイント】

■（除外シートを除いた）１枚目のシートの転記元セルの値が左から順番に、値を貼り付ける左上セルの右方向に転記します。
■なお、シート名を貼り付けるに☑すると、まずシート名が貼り付けられ、そのあと転記元セルの値を転記します。

■　一つ目のシートが終わると、次のシートを順次処理します。

表示されるVBAコード

アプリで作成されたコードを、VBE画面に貼り付ければ、マクロの完成です。

VBAコードを見る

Sub 月末残高転記() '複数シートから、同一セルの値を抽出し、一覧表にする
Application.ScreenUpdating = False ' 画面描画を停止
Application.DisplayAlerts = False ' 警告表示を停止
'◆処理前のデータを削除する
Worksheets("総括表").Select
If Range("a2") <> "" Then
Range("a2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.ClearContents
Selection.ClearHyperlinks
Selection.Font.Underline = False
Selection.Font.ColorIndex = xlAutomatic
End If
'◆シートごとに処理をする
Dim シート As Worksheet, アドレス As Variant, 配列2次元(), 行 As Long
Dim 除外辞書 As Object, 対象辞書 As Object, 配列 As Variant
Dim 除外配列 As Variant, 対象配列 As Variant, 数 As Long, i As Long
Set 除外辞書 = CreateObject("Scripting.Dictionary")
Set 対象辞書 = CreateObject("Scripting.Dictionary")
'除外配列に、除外対象を代入
配列 = Split("原本,総括表", ",")
除外配列 = 配列
For 数 = 0 To UBound(除外配列)
除外辞書.Add 除外配列(数), "除外"
Next 数
'シート名が除外辞書になければ、対象辞書に加える
For Each シート In Worksheets
If Not 除外辞書.Exists(シート.Name) Then
対象辞書.Add シート.Name, "対象"
End If
Next シート
'対象のキーを、配列に入れる
対象配列 = 対象辞書.keys
'配列に入れた対象に、順次処理をする
For Each シート In Worksheets(対象配列)
'◆シート一覧作成
columns("a").NumberFormat = "@"
Range("a" & 2 + i) = シート.Name
ActiveSheet.Hyperlinks.Add Anchor:=Range("a" & 2 + i), _
Address:="", _
SubAddress:=シート.Name & "!A1", _
TextToDisplay:=シート.Name
i = i + 1
'◆対象セルの値で、リストを作る
Dim 列 As Long, セル As Variant
行 = 行 + 1
アドレス = Split("a2,e11", ",")
'２次元側に「行」をいれて、要素数を変更
ReDim Preserve 配列2次元(1 To UBound(アドレス) + 1, 1 To 行)
For Each セル In アドレス
列 = 列 + 1
配列2次元(列, 行) = シート.Range(セル).Value
Next セル
列 = 0
'串刺し計算をする
Dim 串刺 As String
If 串刺 = "" Then
串刺 = シート.Name & "!E11"
Else
串刺 = 串刺 & "," & シート.Name & "!E11"
End If
Next
'◆２次元の行列を入れ替えて、貼り付け
Sheets("総括表").Range("a2").Offset(0, 1).Resize(行, UBound(アドレス) + 1) = Application.Transpose(配列2次元)

'串刺しを貼り付け
Sheets("総括表").Range("C8").Formula = "=SUM(" & 串刺 & ")"
Application.DisplayAlerts = True ' 警告表示を再開
Application.ScreenUpdating = True ' 画面描画を再開
End Sub