2024/11/12

Excel VBA 週ごとに縦に並んだ表を横並びにする方法 | Find&Set

仕事でVBAを使うことがあり、やりたいことはネットで調べていますが、VBA初心者の私が分かりづらかったものを、初心者でも分かるように説明したいと思います。

効率的なコードが書けていない可能性もありますので、予めご了承ください。

今回は週ごとに縦に並んだ表を、Findとsetを使用し、横並びにする方法を紹介します。

使用ケース
完成イメージ
マクロ仕様
サンプルコード
コード解説

使用ケース

以下のような、週ごとに行を変えて縦に並べた表、会社で作る人いませんか？

視覚的には見やすいのかもしれませんが、表の情報を取り込んだりする場合には扱いにくく、データの仕様的にはあまりイケていません。

今回のケースは、このように縦に並んだ表のデータを取り込んで、扱いやすくするために横並びにする方法を紹介したいと思います。

縦に並んだ表の仕様としては、

ファイル名は「担当表.xlsx」とする。
担当者の行が増減する。
一番下の担当者は変わらない。

完成イメージ

縦に並んだ表の情報を、マクロを組んだブックに取り込み、横並びにします。

マクロ仕様

先にマクロの動きを説明したいと思います。

ざっくりいうと、各週ごとに一番上の担当名から、一番下の担当者の最終列の範囲をコピーして貼り付けるを繰り返しています。

もっといい方法があるような気もしますが、私はこの方法を取りました。

①担当表のファイルを開く
②A列から変数に格納したname1（鈴木）を検索し、セル位置m1を取得（黄色セル）
③m1の一つ上のセル位置ma1を取得
④ma1と最終行の間からname1（鈴木）を検索し、セル位置m2を取得（ピンクセル）
⑤m2の右上のセル位置ma2を取得 ※②で名前を取得する用意をしているため、ここでは日付部分から
⑥④～⑤を計3回繰り返し、セル位置を取得（ma3～ma5）
⑦A列から変数に格納したname2（山本）を検索し、セル位置y1を取得（赤色セル）
⑧y1から右に7つ移動したセル位置ya1を取得（水色セル）
⑨y1の一つ下のセルと最終行の間からname2（山本）を検索し、セル位置y2を取得（緑色セル）
⑩y2から右に7つ移動したセル位置ya2を取得（水色セル）
⑪⑨～⑩を計3回繰り返し、セル位置を取得（ya3～ya5）
⑫ma1～ya1をコピーして、マクロファイルに貼り付け
⑬ma2～ya2をコピーして、マクロファイルに、⑫で貼り付けた位置から8つ右に貼り付け（最初の貼り付けのみ名前があるため8つ）
⑭ma3～ya3をコピーして、マクロファイルに、⑬で貼り付けた位置から7つ右に貼り付け
⑮ma4・5～ya4・5で繰り返す

サンプルコード

まずはコード全文です。セクションごとの解説は後述します。


Sub 横並び変換()

Dim targetWorkbook
Dim m1, m2, m3, m4, m5, m6
Dim y1, y2, y3, y4, y5, y6
Dim name1, name2


Set targetWorkbook = Workbooks.Open(Filename:="C:\Users\Owner\Desktop\担当表.xlsx", ReadOnly:=True)
Sheets(1).Select
Lastrow = Cells(Rows.Count, 1).End(xlUp).Row

name1 = "鈴木"

Set m1 = Range(Cells(2, 1), Cells(Lastrow, 1)).Find(name1, SearchOrder:=xlByColumns)
ma1 = m1.Offset(-1, 0).Address

Set m2 = Range(m1.Offset(0, 1), Cells(Lastrow, 1)).Find(name1, SearchOrder:=xlByColumns) 
ma2 = m2.Offset(-1, 1).Address

Set m3 = Range(m2.Offset(0, 1), Cells(Lastrow, 1)).Find(name1, SearchOrder:=xlByColumns) 
ma3 = m3.Offset(-1, 1).Address

Set m4 = Range(m3.Offset(0, 1), Cells(Lastrow, 1)).Find(name1, SearchOrder:=xlByColumns) 
ma4 = m4.Offset(-1, 1).Address

Set m5 = Range(m4.Offset(0, 1), Cells(Lastrow, 1)).Find(name1, SearchOrder:=xlByColumns) 
ma5 = m5.Offset(-1, 1).Address


name2 = "山本"

Set y1 = Range(Cells(2, 1), Cells(Lastrow, 1)).Find(name2, SearchOrder:=xlByColumns)
ya1 = y1.Offset(0, 8).Address

Set y2 = Range(y1.Offset(0, 1), Cells(Lastrow, 1)).Find(name2, SearchOrder:=xlByColumns) 
ya2 = y2.Offset(0, 8).Address

Set y3 = Range(y2.Offset(0, 1), Cells(Lastrow, 1)).Find(name2, SearchOrder:=xlByColumns) 
ya3 = y3.Offset(0, 8).Address

Set y4 = Range(y3.Offset(0, 1), Cells(Lastrow, 1)).Find(name2, SearchOrder:=xlByColumns) 
ya4 = y4.Offset(0, 8).Address

Set y5 = Range(y4.Offset(0, 1), Cells(Lastrow, 1)).Find(name2, SearchOrder:=xlByColumns) 
ya5 = y5.Offset(0, 8).Address

ThisWorkbook.Worksheets("貼付").Activate
LastRowy = Cells(Rows.Count, 1).End(xlUp).Row
Range("A4:AJ" & LastRowy).Clear

Workbooks(Workbooks.Count).Activate
	Sheets(1).Select
	Range(ma1, ya1).Copy
	ThisWorkbook.Activate
	Worksheets("貼付").Activate
	Application.DisplayAlerts = False
	Range("A2").PasteSpecial Paste:=xlPasteValues
	Range("A2").PasteSpecial Paste:=xlPasteFormats

Workbooks(Workbooks.Count).Activate
	Sheets(1).Select
	Range(ma2, ya2).Copy
	ThisWorkbook.Activate
	Worksheets("貼付").Activate
	Application.DisplayAlerts = False
	Range("I2").PasteSpecial Paste:=xlPasteValues
	Range("I2").PasteSpecial Paste:=xlPasteFormats

Workbooks(Workbooks.Count).Activate
	Sheets(1).Select
	Range(ma3, ya3).Copy
	ThisWorkbook.Activate
	Worksheets("貼付").Activate
	Application.DisplayAlerts = False
	Range("P2").PasteSpecial Paste:=xlPasteValues
	Range("P2").PasteSpecial Paste:=xlPasteFormats

Workbooks(Workbooks.Count).Activate
	Sheets(1).Select
	Range(ma4, ya4).Copy
	ThisWorkbook.Activate
	Worksheets("貼付").Activate
	Application.DisplayAlerts = False
	Range("W2").PasteSpecial Paste:=xlPasteValues
	Range("W2").PasteSpecial Paste:=xlPasteFormats

Workbooks(Workbooks.Count).Activate
	Sheets(1).Select
	Range(ma5, ya5).Copy
	ThisWorkbook.Activate
	Worksheets("貼付").Activate
	Application.DisplayAlerts = False
	Range("AD2").PasteSpecial Paste:=xlPasteValues
	Range("AD2").PasteSpecial Paste:=xlPasteFormats

Workbooks(Workbooks.Count).Close SaveChanges:=False
ThisWorkbook.Worksheets("貼付").Range("A2").Select

End Sub

コード解説

コードが長くなってしまったため、基本的にコメントで解説していきます。

ファイルを開いて変数格納


Set targetWorkbook = Workbooks.Open(Filename:="C:\Users\Owner\Desktop\担当表.xlsx", ReadOnly:=True) '元ファイルを読み取り専用で開いて変数に格納
Sheets(1).Select '最初のシートを選択
Lastrow = Cells(Rows.Count, 1).End(xlUp).Row 'A列の最終行取得

1行目の担当者をセット

1行目の担当者名をname1にセットします。変数にすることで、名前が変わってもすぐに更新が可能です。


name = "鈴木"

name1を検索しセル取得

name1をfindで検索し、Offsetでname1のあるセルから1つ上のセルを指定し、セル位置をma1へ格納します。


Set m1 = Range(Cells(2, 1), Cells(Lastrow, 1)).Find(name1, SearchOrder:=xlByColumns)
ma1 = m1.Offset(-1, 0).Address

2つ目のname1を検索しセル取得

この部分がこのマクロのポイントで、検索範囲を「Range(m1.Offset(0, 1), Cells(Lastrow, 1))」として、前述部分で変数に格納したm1の一つ下から最終列に指定しています。

その範囲を、検索範囲内に検索値が複数ある場合、最初の検索値をヒットするfindの特性を生かし、name1の2つ目のセル位置を検索。

その後、Offsetで右上のセルを指定し、セル位置をma2へ格納しています。


Set m2 = Range(m1.Offset(0, 1), Cells(Lastrow, 1)).Find(name1, SearchOrder:=xlByColumns) 
ma2 = m2.Offset(-1, 1).Address

3つ目～5つ目のname1を検索しセル取得

あとは2つ目の検索と同様に、3～5つ目を繰り返します。


Set m3 = Range(m2.Offset(0, 1), Cells(Lastrow, 1)).Find(name1, SearchOrder:=xlByColumns) 
ma3 = m3.Offset(-1, 1).Address

Set m4 = Range(m3.Offset(0, 1), Cells(Lastrow, 1)).Find(name1, SearchOrder:=xlByColumns) 
ma4 = m4.Offset(-1, 1).Address

Set m5 = Range(m4.Offset(0, 1), Cells(Lastrow, 1)).Find(name1, SearchOrder:=xlByColumns) 
ma5 = m5.Offset(-1, 1).Address

name2で繰り返し

name1で行った動作をname2で繰り返します。


name2 = "山本"

Set y1 = Range(Cells(2, 1), Cells(Lastrow, 1)).Find(name2, SearchOrder:=xlByColumns)
ya1 = y1.Offset(0, 8).Address

Set y2 = Range(y1.Offset(0, 1), Cells(Lastrow, 1)).Find(name2, SearchOrder:=xlByColumns) 
ya2 = y2.Offset(0, 8).Address

Set y3 = Range(y2.Offset(0, 1), Cells(Lastrow, 1)).Find(name2, SearchOrder:=xlByColumns) 
ya3 = y3.Offset(0, 8).Address

Set y4 = Range(y3.Offset(0, 1), Cells(Lastrow, 1)).Find(name2, SearchOrder:=xlByColumns) 
ya4 = y4.Offset(0, 8).Address

Set y5 = Range(y4.Offset(0, 1), Cells(Lastrow, 1)).Find(name2, SearchOrder:=xlByColumns) 
ya5 = y5.Offset(0, 8).Address

リセット

貼付け先となるマクロブックの、前回貼付けした内容をリセットするために、最終行を変数に格納し、指定範囲をクリアします。


ThisWorkbook.Worksheets("貼付").Activate 'シート「貼付」を選択
LastRowy = Cells(Rows.Count, 1).End(xlUp).Row　'最終行を検索
Range("A4:AJ" & LastRowy).Clear 'リセットのため貼付け部分をクリア

格納した範囲をコピーしマクロファイルへ貼り付け

前述部分で変数に格納したセル位置を、「Range(ma1, ya1).Copy」で範囲指定コピーし、値＋書式貼り付けします。


Workbooks(Workbooks.Count).Activate
	Sheets(1).Select
	Range(ma1, ya1).Copy
	ThisWorkbook.Activate
	Worksheets("貼付").Activate
	Application.DisplayAlerts = False
	Range("A2").PasteSpecial Paste:=xlPasteValues
	Range("A2").PasteSpecial Paste:=xlPasteFormats

2～5で繰り返し

おそらくfor文で短縮化できると思いますが、今回は分かりやすくいきたいと思います。


Workbooks(Workbooks.Count).Activate
	Sheets(1).Select
	Range(ma2, ya2).Copy
	ThisWorkbook.Activate
	Worksheets("貼付").Activate
	Application.DisplayAlerts = False
	Range("I2").PasteSpecial Paste:=xlPasteValues
	Range("I2").PasteSpecial Paste:=xlPasteFormats

Workbooks(Workbooks.Count).Activate
	Sheets(1).Select
	Range(ma3, ya3).Copy
	ThisWorkbook.Activate
	Worksheets("貼付").Activate
	Application.DisplayAlerts = False
	Range("P2").PasteSpecial Paste:=xlPasteValues
	Range("P2").PasteSpecial Paste:=xlPasteFormats

Workbooks(Workbooks.Count).Activate
	Sheets(1).Select
	Range(ma4, ya4).Copy
	ThisWorkbook.Activate
	Worksheets("貼付").Activate
	Application.DisplayAlerts = False
	Range("W2").PasteSpecial Paste:=xlPasteValues
	Range("W2").PasteSpecial Paste:=xlPasteFormats

Workbooks(Workbooks.Count).Activate
	Sheets(1).Select
	Range(ma5, ya5).Copy
	ThisWorkbook.Activate
	Worksheets("貼付").Activate
	Application.DisplayAlerts = False
	Range("AD2").PasteSpecial Paste:=xlPasteValues
	Range("AD2").PasteSpecial Paste:=xlPasteFormats

元ブックを閉じる


Workbooks(Workbooks.Count).Close SaveChanges:=False '最後に開いたブックを閉じる
ThisWorkbook.Worksheets("貼付").Range("A2").Select

以上、週ごとに縦に並んだ表を、Findとsetを使用し、横並びにする方法でした。

今回紹介した方法が最適とは思えませんが、やはりマクロは発想次第で色んな問題を解決できると思った内容でした。

ユーザーフォームを使用した入力フォームの作り方

週ごとに縦に並んだ表を横並びにする方法 | Find&Set

セルに入力された日付を取得し自動でシートとファイルを作る方法

検索窓にキーワードを入力しEnterキーで検索するフォームの作り方 | Intersect

ブックを開いた時のウィンドウサイズを指定する方法 | workbook_open

新規ブックを作成しマクロが登録されたボタンを設置する方法 | OnAction

複数のワークシートをまとめて表示・非表示にする方法 | Visible Not.Visible

セル位置が変わっても特定の範囲を選択する方法 | Find&Address

電話番号からハイフンを削除し0から表示させる方法 | Evaluate&Replace

ダイアログボックスからファイルを選択して開く | GetOpenFilename