『複数条件が一致で別シート転記 マクロ』（春日和）
「全データ」シートの複数条件と合致すれば別シートへ転記をしたいです。
ネットで似たマクロを見つけ、自分なりに変更し開始時刻だけの入力は出来ました。下記の1と2を思い通りにするために、お力を貸して頂きたく投稿致しました。よろしくお願いします。
1.「全データ」A列の名前とB列の日付が合致するシートを探し「開始時刻と終了時刻」を転記。
2.転記するシートは担当者毎に10シートあるが増える可能性があるので、全データシートより右だけのシートへ検索し転記。
「全データ」
_ |___A____|___B____|___C____|___D____|
6|名前 |日付 |開始時刻|終了時刻| 7|Aさん |1/1(日) | 10:00 | 16:00 | 8|Bさん |1/1(日) | 12:00 | 20:00 | 7|Aさん |1/2(月) | 15:00 | 20:00 | 8|Bさん |1/2(月) | 12:00 | 20:00 |
転記シートは名前と日付が入力され、シート名は番号「1〜10」で表記
シート名「1」
_ |___A____|___B__|___C____|___D____|
5|名前 |日付 |開始時刻|終了時刻| 6|Aさん |1/1(日) | | | 7|Aさん |1/2(月) | | |
シート名「2」
|___A____|___B___|___C____|___D____|
5|名前 |日付 |開始時刻|終了時刻| 6|Bさん |1/1(日) | | | 7|Bさん |1/2(月) | | |
Sub 各担当へ転記()
Dim Zendata_Sht As Worksheet
Dim Tenki_Sht As Worksheet
Dim MyList() As Variant
Dim LastRow As Long
Dim i As Long
Dim j As Long
Set Zendata_Sht = Sheets("全データ")
Set Tenki_Sht = Sheets("1")
'「全データ」シート A列〜D列のデータを配列に格納
Zendata_Sht.Select
MyList = Zendata_Sht.Range("A6", Range("A" & Rows.Count). _
End(xlUp)).Resize(, 4).Value
'最終行
LastRow = Tenki_Sht.Cells(Rows.Count, 1).End(xlUp).Row
'「転記」シート ループ
For i = 1 To LastRow
For j = 1 To UBound(MyList)
'複数条件一致で別シート転記
If Tenki_Sht.Cells(i, 1) = MyList(j, 1) And _
Tenki_Sht.Cells(i, 2) = MyList(j, 2) Then
Tenki_Sht.Cells(i, 3) = MyList(j, 3)
End If
Next j
Next
End Sub
＜ 使用 Excel：unknown、使用 OS：Windows11 ＞
実は転記シートには、各担当者の希望時間が入力されております。
それを一度、全データへ集約し日付毎にバランス良く時間の調整をしております。
その後修正した内容を各担当シートへ時間の上書きをしたいです。
そのため、関数を使用すると毎回手入力でFilter関数を入力しなければならず、その手間を省きたいです。
よろしくお願いします。
（春日和） 2025/02/21(金) 19:44:15
■１
表が崩れていたので提示のお手伝い。
シート名「全データ」 |___A____|___B____|___C____|___D____| 6|名前 |日付 |開始時刻|終了時刻| 7|Aさん |1/1(日) | 10:00 | 16:00 | 8|Bさん |1/1(日) | 12:00 | 20:00 | 7|Aさん |1/2(月) | 15:00 | 20:00 | 8|Bさん |1/2(月) | 12:00 | 20:00 |
↓
シート名「1」 |___A____|___B____|___C____|___D____| 5|名前 |日付 |開始時刻|終了時刻| 6|Aさん |1/1(日) | | | 7|Aさん |1/2(月) | | |
シート名「2」 |___A____|____B___|___C____|___D____| 5|名前 |日付 |開始時刻|終了時刻| 6|Bさん |1/1(日) | | | 7|Bさん |1/2(月) | | |
■２
やりたいことが単純な振り分けであれば、既に提案があるようにオートフィルタなどで抽出＆コピペを繰り返すだけＯＫでしょう。
そうでなくて既に転記したデータは除外したいとかそういう話であれば、もう少し細かく説明されてはどうでしょうか？
---------書き溜めここまで------------------
■３
＞その後修正した内容を各担当シートへ時間の上書きをしたいです。
ならばなおさら、抽出して【名前も日付も一緒に】貼付したらどうですか？
各シートのA6セルをみれば、名前が掴めるので、それをキーに「全データ」から抽出して上書貼付したらＯＫですよね？
（もこな２ ） 2025/02/21(金) 20:21:02
配列とループを使いたそうだったので。 分かりやすさや効率は考慮していません。
Sub test()
Dim ws As Worksheet
Dim i&, j&, k&, n&
Dim tmp$
Dim v, w
With Worksheets("全データ")
v = Range(.Cells(7, "D"), .Cells(Rows.Count, "A").End(xlUp))
n = .Index
End With
For i = n + 1 To Worksheets.Count
With Worksheets(i)
w = Range(.Cells(6, "D"), .Cells(Rows.Count, "A").End(xlUp))
End With
For j = 1 To UBound(w)
For k = 1 To UBound(v)
If w(j, 1) = v(k, 1) And w(j, 2) = v(k, 2) Then
w(j, 3) = v(k, 3): w(j, 4) = v(i, 4)
End If
Next
Next
With Worksheets(i).Range("A6").Resize(UBound(w), 4)
.Value = w
Intersect(.Cells, .Offset(, 2)).NumberFormatLocal = "h:mm"
End With
Erase w
Next
End Sub
（にわか） 2025/02/21(金) 20:31:03
にわか様
ご返信ありがとうございます。
実行してみたのですが、何も変化が起きませんでした。
（春日和） 2025/02/21(金) 20:43:34
提示されたサンプルの通りだと、変化が起きましたけど・・・ 実情に合わなかったということで、どうぞ捨て置き下さい。 （にわか） 2025/02/21(金) 21:22:11
こんばんは！ にわか さんのは「全データ」シートを一番左にもってきたら動きましたよ？ （SoulMan） 2025/02/21(金) 21:47:15
Sub さんぷる()
Dim SH As Worksheet
With ThisWorkbook.Worksheets("全データ")
.AutoFilterMode = False
.Range("A6").AutoFilter
For Each SH In ThisWorkbook.Worksheets
If SH.Name <> .Name Then
.AutoFilter.Range.AutoFilter Field:=1, Criteria1:=SH.Range("A6").Value
.AutoFilter.Range.Copy SH.Range("A5")
End If
Next SH
End With
End Sub
↑のように、各シートのA6セルの値で抽出したあと、丸ごと各シートのA5セル以降に（上書き）貼付すればよいのでは？と言ったつもりです。
（もこな２ ） 2025/02/21(金) 22:29:08
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.