[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『（マクロ）検索転記について』（スマトラ）
いつも大変お世話になっております。
質問内容は、転記元の検索値が、転記先の項目値と一致したら転記する方法についてです。
・転記元と転記先は同じシート内
・シートは帳票形式で個人に対し1行を使用
・検索値は文字列
シート構成
２行目:項目行
３行目以降:データ範囲
A列:名前
B列〜H列まで出勤する曜日として項目内容を
「月、火、水、木、金、土、日」と入力しております。
I列以降の列は、月の日数によって曜日が変わりますので、
マクロで処理し文字列で流動的に入力されます。
※5月の場合、曜日の始まりは火曜日からですので
I列:火、水、木・・・と31日分曜日がマクロで自動的に
入力されるようにしています。
処理内容
Aさんの出勤日が「月水金」の場合→（例）B3「月」D3「水」F3「金」と
予め入力されています（その他の曜日は空欄）ので・・・
（１）B3:月を検索値として、I列以降範囲の曜日項目を参照
（２）上記曜日とI列一致した場合
（３）一致した列の3行目に「月」と転記
（４）更に次の「月」を検索し一致したら転記・・・・
と該当する曜日分検索し転記していき、3行目が終わったら4行目の処理に移るといった流れで、全体で100人分あります。
上記の処理を行いたいのですが、100人×31日分もあるのでなんとかマクロでできないでしょうか？
皆さま何卒アドバイスの程よろしくお願い致します。
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
（マナ） 2018/05/04(金) 18:30
最終行と最終列が可変なじょうきょうで、
検索と転記範囲が100×31のセル範囲に数式をいれると大変かと思い
マクロでやろうと考えた次第です。
（スマトラ） 2018/05/04(金) 19:49
組んで分かったことがあったので、質問を修正させてください。
実際のシート構成ですので、セル行列が変わっています。
転記元の範囲→BM:BS列（月〜日の順に入力） データ範囲は3行目〜最終行
転記先の範囲→BT:最終列（月日数によって可変）
転記の判断方法→セルBT2の値によって転記元の開始列を決める
BT2が月の場合→BM:BSを7行づつ5週目まで転記
BT2が火の場合→BN:BSを1週目に転記し2周目の始まりは月〜になるので、BM:BSを5週目まで転記
BT2が水の場合・・・・上記にならい1週目だけ転記範囲が変わっていきます。
すべての転記が終わったら、月数からはみ出した値をクリア。
以上が、処理の流れで、下記の通りに作成しました。
ベタなコードなため、月曜〜日曜日始まり各々分岐させるとなんとかなりそうです。
もっと、簡単な方法があればアドバイスの程お願い致します。
Sub シート内カレンダーに基本曜日展開()
Dim sh1 As Worksheet 'シート名:管_予
Dim d As Variant '最終行
Dim c As Variant '最終行
Set sh1 = Worksheets("管_予")
sh1.Select
d = Sheets("管_予").Range("b65536").End(xlUp).Row '名前列から最終行求める
c = Cells(1, Columns.Count).End(xlToLeft).Column '最終列求める
With sh1
.Range("BT3:DB" & d).Value = "" '一旦処理範囲をクリア"
If .Range("BT2").Value = "月" Then
.Range("BT3:BZ" & d).Value = .Range("BM3:BS" & d).Value '１週目 月〜日コピペ
.Range("CA3:CG" & d).Value = .Range("BM3:BS" & d).Value '2週目 以降上に同じでOK
.Range("CH3:CN" & d).Value = .Range("BM3:BS" & d).Value '3週目
.Range("CO3:CU" & d).Value = .Range("BM3:BS" & d).Value '4週目
.Range("CV3:DB" & d).Value = .Range("BM3:BS" & d).Value '5週目
ElseIf .Range("BT2").Value = "火" Then
.Range("BT3:BY" & d).Value = .Range("BN3:BS" & d).Value '１週目 火〜日コピペ
.Range("BZ3:CF" & d).Value = .Range("BM3:BS" & d).Value '2週目 次からは 月〜日コピペでOK
.Range("CG3:CM" & d).Value = .Range("BM3:BS" & d).Value '3週目
.Range("CN3:CT" & d).Value = .Range("BM3:BS" & d).Value '4週目
.Range("CU3:DA" & d).Value = .Range("BM3:BS" & d).Value '5週目
ElseIf .Range("BT2").Value = "水" Then
End If
.Range(Columns(c + 1), Columns(c + 10)).Value = "" 'カレンダー範囲からはみ出したデータ範囲をクリア
End With
End Sub
（スマトラ） 2018/05/04(金) 20:39
Sub test()
Dim f As String
f = "=IF(COUNTIF($BM3:$BS3,BT$2),BT$2,"""")"
Range("BT3").Resize(150, 31).Formula = f
End Sub
手作業で式入力がもっと簡単ですが。
（マナ） 2018/05/04(金) 20:48
もし、BM2:BS2に月〜日が入力されているなら
フィルタオプション（詳細設定）も簡単かも
（マナ） 2018/05/04(金) 21:02
今確認したところです。
とりあえず、コードの管理が簡単になるようにCells（行,列）でできました(^_^;)
案を試してみます。
Sub シート内カレンダーに基本利用日展開()
Dim sh1 As Worksheet 'シート名:管_予
Dim d As Variant '最終行
Dim c As Variant '最終行
Set sh1 = Worksheets("管_予")
sh1.Select
d = Sheets("管_予").Range("b65536").End(xlUp).Row '名前列から最終行求める
c = Cells(1, Columns.Count).End(xlToLeft).Column '最終列求める
Application.ScreenUpdating = 0
With sh1
.Range("BT3:DB" & d).Value = "" '一旦処理範囲をクリア"
If .Range("BT2").Value = "月" Then
Range(Cells(3, 72), Cells(d, 72 + 6)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value '(行,列） '１週目 月〜日コピペ
.Range(Cells(3, 72 + 7), Cells(d, 72 + 13)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value '2週目 次からは 月〜日コピペでOK
.Range(Cells(3, 72 + 14), Cells(d, 72 + 20)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value '3週目
.Range(Cells(3, 72 + 21), Cells(d, 72 + 27)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value '4週目
.Range(Cells(3, 72 + 28), Cells(d, 72 + 34)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value '5週目
.Range(Cells(3, 72 + 35), Cells(d, 72 + 41)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value '6週目
ElseIf .Range("BT2").Value = "火" Then
.Range(Cells(3, 72), Cells(d, 72 + 5)).Value = .Range(Cells(3, 66), Cells(d, 66 + 5)).Value '(行,列） '１週目 火〜日コピペ
.Range(Cells(3, 72 + 6), Cells(d, 72 + 12)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
.Range(Cells(3, 72 + 13), Cells(d, 72 + 19)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
.Range(Cells(3, 72 + 20), Cells(d, 72 + 26)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
.Range(Cells(3, 72 + 27), Cells(d, 72 + 33)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
.Range(Cells(3, 72 + 34), Cells(d, 72 + 40)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
ElseIf .Range("BT2").Value = "水" Then
.Range(Cells(3, 72), Cells(d, 72 + 4)).Value = .Range(Cells(3, 67), Cells(d, 67 + 4)).Value
.Range(Cells(3, 72 + 5), Cells(d, 72 + 11)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
.Range(Cells(3, 72 + 12), Cells(d, 72 + 18)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
.Range(Cells(3, 72 + 19), Cells(d, 72 + 25)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
.Range(Cells(3, 72 + 26), Cells(d, 72 + 32)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
.Range(Cells(3, 72 + 33), Cells(d, 72 + 39)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
ElseIf .Range("BT2").Value = "木" Then
.Range(Cells(3, 72), Cells(d, 72 + 3)).Value = .Range(Cells(3, 68), Cells(d, 68 + 3)).Value
.Range(Cells(3, 72 + 4), Cells(d, 72 + 10)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
.Range(Cells(3, 72 + 11), Cells(d, 72 + 17)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
.Range(Cells(3, 72 + 18), Cells(d, 72 + 24)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
.Range(Cells(3, 72 + 25), Cells(d, 72 + 31)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
.Range(Cells(3, 72 + 32), Cells(d, 72 + 38)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
ElseIf .Range("BT2").Value = "金" Then
.Range(Cells(3, 72), Cells(d, 72 + 2)).Value = .Range(Cells(3, 69), Cells(d, 69 + 2)).Value
.Range(Cells(3, 72 + 3), Cells(d, 72 + 9)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
.Range(Cells(3, 72 + 10), Cells(d, 72 + 16)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
.Range(Cells(3, 72 + 17), Cells(d, 72 + 23)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
.Range(Cells(3, 72 + 24), Cells(d, 72 + 30)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
.Range(Cells(3, 72 + 31), Cells(d, 72 + 37)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
ElseIf .Range("BT2").Value = "土" Then
.Range(Cells(3, 72), Cells(d, 72 + 1)).Value = .Range(Cells(3, 70), Cells(d, 70 + 1)).Value
.Range(Cells(3, 72 + 2), Cells(d, 72 + 8)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
.Range(Cells(3, 72 + 9), Cells(d, 72 + 15)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
.Range(Cells(3, 72 + 16), Cells(d, 72 + 22)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
.Range(Cells(3, 72 + 23), Cells(d, 72 + 29)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
.Range(Cells(3, 72 + 30), Cells(d, 72 + 36)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
ElseIf .Range("BT2").Value = "日" Then
.Range(Cells(3, 72), Cells(d, 72 + 1)).Value = .Range(Cells(3, 71), Cells(d, 71)).Value
.Range(Cells(3, 72 + 1), Cells(d, 72 + 7)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
.Range(Cells(3, 72 + 8), Cells(d, 72 + 14)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
.Range(Cells(3, 72 + 15), Cells(d, 72 + 21)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
.Range(Cells(3, 72 + 22), Cells(d, 72 + 28)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
.Range(Cells(3, 72 + 29), Cells(d, 72 + 35)).Value = .Range(Cells(3, 65), Cells(d, 65 + 6)).Value
End If
.Range(Columns(c + 1), Columns(c + 10)).Value = "" 'カレンダー範囲からはみ出したデータ範囲をクリア
End With
Application.ScreenUpdating = 1
End Sub
（スマトラ） 2018/05/04(金) 21:38
気になったところ
（１）
「sh1.Select」となっているところについて、おそらくコードを標準モジュールに記述していて、後に出てくるCellsプロパティの修飾を省略していて、ActiveSheet.Cells（○○）という意味になっちゃうから入れてるのでしょうけど、せっかく「With sh1」としているのですから、Activesheetありきではなく、シートをちゃんと修飾したほうがかっこいいんじゃないでしょうか（「.」入れるだけで済みますし、そのように修正すれば「sh1.Select」は要らないですよね）
（２）
「d = Sheets("管_予").Range("b65536").End(xlUp).Row」となっているところについて、問題なく動くんでしょうけど、Excel2010ですと最終行は65536行目でない場合もありますし、次の列番号を取得するほうでは、「.Count」してるので、そこはそろえた方が見栄えがいいような気がします。
（３）
下記の変数「sh1」について、（１）とも絡みますが、もし（１）のとおり修正すると、「With sh1」でしか使ってないことになるので、変数にせず「With Worksheets("管_予")」とすればいいような気がします。
Dim sh1 As Worksheet 'シート名:管_予
Set sh1 = Worksheets("管_予")
With sh1
〜
End With
↓
With Worksheets("管_予")
〜
End With
（４）
「Application.ScreenUpdating = 0」について、意味がわかっていて入れているなら否定はしませんけど、私ならテスト動作させたときに想定外の動作をしているなどのバグを見落とす原因にもなるので、コードが完成するまで（安定動作が確認されるまで）入れないです。
（５）
「.Range("BT2").Value」の値によってIF（とElseIF）で条件分岐してますが、好みの問題ではありますけど、評価する対象が同じなら「Select Case」使ってみてもいいんじゃないかなと思います。
（６）
月曜日〜日曜日までの分岐部分について、１週目はともかくとして２週目以降は７列おきに同じセル範囲の参照を繰り返してるだけのようにおもいます。Excel君はこのような単純な繰り返しは大得意なので、全部書かなくても７ずつずらして繰り返せという指示をしてあげればよいと思います。
以上を踏まえると、こんな感じでもいけるんじゃないかとおもいます。
（実データがないのでコンパイルエラーにならないことくらいしかチェックしてないですが・・・）
Sub test()
Dim d As Long '最終行番号
Dim c As Long '最終"列"番号
Dim MyRNG As Range, i As Long, a As Long
With Worksheets("管_予")
d = .Cells(.Rows.Count, "B").End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
'一旦処理範囲をクリア"
.Range(.Cells(3, "BT"), .Cells(d, "DB")).ClearContents
Set MyRNG = .Range(.Cells(3, 65), .Cells(d, 65 + 6))
Select Case .Range("BT2").Value
Case Is = "月": a = 0
Case Is = "火": a = 1
Case Is = "水": a = 2
Case Is = "木": a = 3
Case Is = "金": a = 4
Case Is = "土": a = 5
Case Is = "日": a = 6
End Select
With .Range(.Cells(3, 72), .Cells(d, 78))
.Resize(.Rows.Count, .Columns.Count - a).Value = _
MyRNG.Offset(0, a).Resize(MyRNG.Rows.Count, MyRNG.Columns.Count - a).Value '１週目
For i = 7 - a To 35 - a Step 7
.Offset(0, i).Value = MyRNG.Value '2〜6週目
Next i
End With
'カレンダー範囲からはみ出したデータ範囲をクリア
.Range(Columns(c + 1), Columns(c + 10)).ClearContents
End With
End Sub
（もこな２） 2018/05/06(日) 00:23
Select Case .Range("BT2").Value
Case Is = "月": a = 0
Case Is = "火": a = 1
Case Is = "水": a = 2
Case Is = "木": a = 3
Case Is = "金": a = 4
Case Is = "土": a = 5
Case Is = "日": a = 6
End Select
↓
a = Application.Match(.Range("BT2").Value, Array("月", "火", "水", "木", "金", "土", "日"), 0)
If IsError(a) Then
MsgBox "「BT2」セルに月〜日までの値が入っていません。" & vbCrLf & "処理を中断します。"
Exit Sub
Else
a = a - 1
End If
（もこな２） 2018/05/06(日) 12:21
実際に動かして試しました、コードがかなりスリムになりびっくりしました。
コード一つでここまで変わるもんなんですね。
動作も問題なかったです。
とにかく、ご提示されるまで、コードを見直しておりました。
コードが長いと修正が大変ですから助かります。
解決できました。
（スマトラ） 2018/05/06(日) 13:54
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.