[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『マクロで転記したいのですが』（太陽）
excel2003 winxp
シート構成が２枚で１枚目がデータのシートです。 ２枚目は出来上がっているプリントのためのシートです。 単純な成績管理のようなものです。
人数が多くなり一人でフィルターを掛けてコピー＆ペーストが 発表の日までに間に合わなくなってしまって苦労なので マクロでどうかと考えたのですが、 複数回繰り返したり、氏名の数だけという条件が マクロの記録ではわかりません。
シート１ a b c d 日付 氏名 番号 数量
シート２ a b c 日付 番号 数量
上記のようなシート構成になってます。 シート２の日付は１か月分入力されています。
シート１のb列をオートフィルタで一人づつ選択して その人間のデータのシート１の日付とシート２の日付とが一致したら シート１のｃ・ｄ列の数値をシート２のｂ・ｃ列に抽出したデータの 数だけ転記させたいのです
その後、上記の動作をシート１の氏名の数だけ繰り返したいのですが 上記の説明で大丈夫でしょうか？
どなたかよろしくお願いいたします。
シート１で氏名だけオートフィルターするのではなく、氏名と日付で抽出して転記すれば楽なように 思いますけど。
⇒シート２の日付は１か月分入力されています。 結局は開始日と終了日があるんですよね？ 氏名とあわせて条件として与えればいいのかな〜と感じますが。（あくまで案ですが） (じゅんじゅん)
>結局は開始日と終了日があるんですよね？ そうです。一か月の集計になっています
>シート１で氏名だけオートフィルターするのではなく、氏名と日付で抽出して転記すれば楽なように 思いますけど。 氏名だけでも何十人もいるので複雑になりませんか？
（太陽）
>氏名だけでも何十人もいるので複雑になりませんか？ シート２に表示したいのは、ある人のある期間についてではないでしょうか。 ならば、シート１で”ある人”だけを抽出して、シート２の”ある期間”に該当する云々より、 楽かな？と思った次第です。
>複数回繰り返したり、氏名の数だけという条件が 繰り返してシート２に羅列するのか、抽出毎に印刷するのか？ シート２には”氏名”がないので、どうされるかはわかりませんが、 一案として頂ければ。 (じゅんじゅん)
説明が足りなくてすみませんでした。
”ある人”というキーワードがバイトさんの氏名でよく入れ替わるので固定化できません。 今月なら今月に存在する氏名の分だけ抽出したいのがまず１点。
複数回繰り返すのは、aさんをシート２に転記したらプリントして、さらに別のブック に氏名ごとのシートを作成して保存。その後シート２のｂ列とｃ列をクリアして・・・ というのをシート１のa列の名前の数だけ繰り返すという意味です。
シート２には
a b c １ 氏名 ２ ３ 日付 番号 数量
こんな感じで氏名がございます。省略してしまってすみません。 （太陽）
ご参考になりませんか？ (じゅんじゅん)
すみません。少しご説明願えませんか？
まず、期待以上の結果でした。 このマクロを使用した結果、新しく作成される氏名毎のシートに発生する 氏名の列、私の今回使用したデータの場合３列目を氏名列にして 新しいシートにも３列目に氏名列が出来てしまったのですが、 １・２・４・５列目だけの転記って可能ですか？６列目からは 転記先のシートに数式が入っているので…
それとですね、飛ばした先に書式設定されているものが列幅やその他が 狂うのであくまでも値貼り付けのような結果などは可能ですか？
それと、どこでどんな実行をしているのか簡単に説明していただけますか？ お時間があればで結構です。
私ももう一回ブレークポイントってのを全部にやって観察してみます。 （太陽）
Sub Test()
Dim Dic As Object
Dim key As Variant
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim Csh As Worksheet
Dim r As Range
Application.ScreenUpdating = False
Set sh1 = Worksheets("テスト")
Set Dic = CreateObject("Scripting.Dictionary")
With sh1
For Each r In .Range(.[c2], .Cells(Rows.Count, "c").End(xlUp))
Dic(r.Value) = Empty
Next
End With
For Each key In Dic.keys
For Each Csh In Worksheets
If key = Csh.Name Then
Application.DisplayAlerts = False
Csh.Delete
Application.DisplayAlerts = True
End If
Next
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = key
Set sh2 = Worksheets(key)
With sh2
.Range("a1").Value = key
End With
With sh1
.Range("A1").AutoFilter Field:=3, Criteria1:=key
.Range("A1").CurrentRegion.Copy Destination:=Worksheets(key).Range("a3")
.AutoFilterMode = False
End With
Next
Set Dic = Nothing Set sh1 = Nothing Set sh2 = Nothing Application.ScreenUpdating = True End Sub
>.Range("A1").CurrentRegion.Copy Destination:=Worksheets(key).Range("a3")
この行ですが仮に一番右下のセルが空白であった場合
例 ５列のうち４列目までしか入力の無いセルがたまたまあった場合。
どうなりますか？
>>.Range("A1").CurrentRegion.Copy Destination:=Worksheets(key).Range("a3")
>この行ですが仮に一番右下のセルが空白であった場合
>例 ５列のうち４列目までしか入力の無いセルがたまたまあった場合。
>どうなりますか？
.Range("A1").CurrentRegion この範囲内であれば貼り付くと思いますよ。
参考ＵＲＬ
http://www.moug.net/tech/exvba/0050089.htm
(じゅんじゅん)
何度もすみません。範囲については理解しました。 値コピーについてはどうでしょうか？
可能でしょうか？ Paste:=xlPasteValues←こんなのをどこに入れたらいいのか？？？ お願いします （太陽）
With sh1
.Range("A1").AutoFilter Field:=3, Criteria1:=key
.Range("A1").CurrentRegion.Copy
sh2.Range("a3").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
.AutoFilterMode = False
End With
これでは、どうでしょうか？(こうかな）
(じゅんじゅん)
個人ごとに分けることは理想通りのものになりました。ありがとうございます
お時間があればもう少しお聞きしたいのですが これは範囲をそっくり転記する動作ですが、当初の目的のa列に日付が１ヶ月分入っている シート２にこの個人で分けられたデータを転記していくのは自動で行うのはどうでしょうか？
また、この場合新規に氏名でシートを作成していくのですが 理想の順番だと
シート１から１人目のデータをシート２のカレンダーに一致する日付の分だけ転記する ↓ 転記したものを（シート２）印刷する ↓ シート２の内容をシートごとその１人目の氏名の名前でシートを作成しコピーする ↓ シート２をデータを転記したところだけ削除して元に戻す ↓ シート１から今度は２人目のデータを…
とこのような動作ををデータの人数分だけ繰り返したいのです。
分ける過程で組み込めないものかと考えたのですが難しそうですね。 （太陽）
文章で説明するのって本当に難しいですね。 以前にあったアップローダーって今は使えないのですね？ （太陽）
例えばこの様な表があったとして、
A B
1 日付 名前
2 7月9日
3 7月13日
4 7月17日
5 7月21日
6 7月25日
7 7月29日
8 8月2日
9 8月6日 a
10 8月10日
11 8月14日 a
12 8月18日
13 8月22日 a
14 8月26日
15 8月30日
16 9月3日
今月の名前"a"を抽出するなら、
Sub test()
Dim mon1 As Date, mon2 As Date
mon1 = DateSerial(Year(Date), Month(Date), 1) '今月１日
mon2 = DateSerial(Year(Date), Month(Date) + 1, 0) '今月末
Range("A1").AutoFilter 1, ">=" & mon1, xlAnd, "<=" & mon2
Range("A1").AutoFilter 2, "=a"
End Sub
で、いけるかと。そうすれば、シート２のＡ列の値にあわせる事もないと思います。
試してみて下さい。
(じゅんじゅん)
説明不足を繰り返してすみません。 以下の通りの書式がシート２には用意されています
シート2
A B C
1 氏名
2
3 8/1
4 8/2
5 8/3
6 8/4
7 8/5
8 8/6
∫
33 8/31
シート１のデータの中からフィルターで一人づつ選択してフィルターをかけ、かけた人間の氏名を 転記して日付条件がが一致すればその日付のＢ列以降を転記する。（データーは何か月分もあるものなので） 必要なのは一月分なのですが、というものです。その作業を人数分繰り返すのです。
いつもの作業でフィルターを使って一人づつコピーしていて、しかもデータのシートのように 飛び飛びでぎっしりでなくカレンダーの中で出ている日だけ貼り付けて…なんでこんな要求するかなぁ
しかも人数分ですが毎月人間は入れ替わるし、で自動で出来ないかと単純に考えてしまったわけです 無理言ってすみません（太陽）
Sub Test()
Dim Dic As Object
Dim key As Variant
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim Csh As Worksheet
Dim r As Range
Application.ScreenUpdating = False
Set sh1 = Worksheets("テスト")
Set Dic = CreateObject("Scripting.Dictionary")
With sh1
For Each r In .Range(.[c2], .Cells(Rows.Count, "c").End(xlUp))
Dic(r.Value) = Empty
Next
End With
For Each key In Dic.keys
For Each Csh In Worksheets
If key = Csh.Name Then
Application.DisplayAlerts = False
Csh.Delete
Application.DisplayAlerts = True
End If
Next
Worksheets.Add After:=Worksheets(Worksheets.Count)
'--------------------------------------------------------------------
'ここにシート２のスタイルをコピペして
'--------------------------------------------------------------------
ActiveSheet.Name = key
Set sh2 = Worksheets(key)
With sh2
.Range("a1").Value = key
End With
With sh1
'--------------------------------------------------------------------
'以下の操作で日付条件で一致する列を転記させる
.Range("A1").AutoFilter Field:=3, Criteria1:=key
.Range("A1").CurrentRegion.Copy
Worksheets(key).Range("a3").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
.AutoFilterMode = False
'--------------------------------------------------------------------
End With
Next
Set Dic = Nothing Set sh1 = Nothing Set sh2 = Nothing Application.ScreenUpdating = True '-------------------------------------------------------------------- '最後に全てのシートを印刷する '-------------------------------------------------------------------- End Sub この様なイメージでは駄目ですか？（太陽）
ファイルをコピーし、シート２が存在するとして下記コードがうまく動くかどうかですが。 (７月の日付があると仮定した場合）
Sub Test12()
Dim Dic As Object
Dim key As Variant
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim r As Range
Dim mon1 As Date, mon2 As Date
Dim v As Variant
Dim i As Integer
mon1 = DateSerial(Year(Date), Month(Date) - 1, 1) '先月１日
mon2 = DateSerial(Year(Date), Month(Date), 0) '先月末
Application.ScreenUpdating = False
Set sh1 = Worksheets("テスト")
Set sh2 = Worksheets("Sheet2")
Set Dic = CreateObject("Scripting.Dictionary")
With sh1
For Each r In .Range(.[c2], .Cells(Rows.Count, "c").End(xlUp))
Dic(r.Value) = Empty
Next
End With
For Each key In Dic.keys
With sh1
.Range("A1").AutoFilter 1, ">=" & mon1, xlAnd, "<=" & mon2
.Range("A1").AutoFilter Field:=3, Criteria1:=key
.Range("A1").CurrentRegion.Copy
sh2.Range("A50").PasteSpecial Paste:=xlPasteValues
.AutoFilterMode = False
End With
v = sh2.Range("A50").CurrentRegion.Value
For Each r In sh2.Range("A3:A33")
For i = 1 To UBound(v, 1)
If r.Value = v(i, 1) Then
r.Offset(, 1).Value = v(i, 4)
r.Offset(, 2).Value = v(i, 5)
Exit For
End If
Next
Next
MsgBox "ひとりめ終わり" End Sub
Next Set Dic = Nothing Set sh1 = Nothing Set sh2 = Nothing Application.ScreenUpdating = True End Sub
シート２の５０行目以降にデータがないとしてます。 こちらでの検証ができてませんが。 (じゅんじゅん)
For Each r In sh2.Range("A3:A33")
For i = 1 To UBound(v, 1)
If r.Value = v(i, 1) Then
r.Offset(, 1).Value = v(i, 4)
r.Offset(, 2).Value = v(i, 5)
Exit For
End If
Next
Next
↓
Dim j As Integer
For i = 1 To UBound(v, 1)
On Error Resume Next
j = Application.Match(v(i, 1), sh2.Range("A3:A33"), 0)
On Error GoTo 0
If j > 0 Then
Range("A2").Offset(j, 2).Value = v(i, 4)
Range("A2").Offset(j, 2).Value = v(i, 5)
End If
Next
かな？
(じゅんじゅん)
遅くまで考えていただいてすみません。 これから検証してみます。 （太陽）
Sub Test12()
Dim Dic As Object
Dim key As Variant
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim r As Range
Dim mon1 As Date, mon2 As Date
Dim v As Variant
Dim i As Integer
mon1 = DateSerial(Year(Date), Month(Date) - 1, 26) '先月26日
mon2 = DateSerial(Year(Date), Month(Date), 25) '先月25
Application.ScreenUpdating = False
Set sh1 = Worksheets("テスト")
Set sh2 = Worksheets("Sheet2")
Set Dic = CreateObject("Scripting.Dictionary")
With sh1
For Each r In .Range(.[c2], .Cells(Rows.Count, "c").End(xlUp))
Dic(r.Value) = Empty
Next
End With
For Each key In Dic.keys
With sh1
.Range("A1").AutoFilter 1, ">=" & mon1, xlAnd, "<=" & mon2
.Range("A1").AutoFilter Field:=3, Criteria1:=key
.Range("A1").CurrentRegion.Copy
sh2.Range("A50").PasteSpecial Paste:=xlPasteValues
.AutoFilterMode = False
End With
'--------------------------------------------------------------------
' With sh2
' .Range("a1").Value = key
' End With
'--------------------------------------------------------------------
v = sh2.Range("A50").CurrentRegion.Value
For Each r In sh2.Range("A3:A33")
For i = 1 To UBound(v, 1)
If r.Value = v(i, 1) Then
r.Offset(, 1).Value = v(i, 2)
r.Offset(, 1).Value = v(i, 4)
r.Offset(, 2).Value = v(i, 5)
r.Offset(, 2).Value = v(i, 6)
Exit For
End If
Next
Next
Dim j As Integer
For i = 1 To UBound(v, 1)
On Error Resume Next
j = Application.Match(v(i, 1), sh2.Range("A3:A33"), 0)
On Error GoTo 0
If j > 0 Then
Range("A2").Offset(j, 2).Value = v(i, 2)
Range("A2").Offset(j, 2).Value = v(i, 4)
Range("A2").Offset(j, 2).Value = v(i, 5)
Range("A2").Offset(j, 2).Value = v(i, 6)
End If
Next
'--------------------------------------------------------------------
' Worksheets.Add After:=Worksheets(Worksheets.Count)
' ActiveSheet.Name = key
' Set sh2 = Worksheets(key)
' With sh2
' .Range("A1").CurrentRegion.Copy Destination:=Worksheets(key).Range("a3")
' End With
’ここにプリントを入れる。
'--------------------------------------------------------------------
MsgBox "ひとりめ終わり"
Next
Set Dic = Nothing Set sh1 = Nothing Set sh2 = Nothing Application.ScreenUpdating = True End Sub 50行目以降になんか残っちゃうのはなぜでしょう？ ここは作業セルになるのですね？ たとえばややこしいですがさらに、作業シートを作成して終了時そのシートに 残ったものを削除するなんてのもありなのですかね？ 一度検証しましたが動作を一部変更したいとすればこんな感じでしょうか？ 明日一番で検証したいと思います。 遅くまでお付き合いいただき有難うございます。過去のマクロの格闘が蘇ってきちゃいました（笑 （太陽）
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
For Each r In sh2.Range("A3:A33")
For i = 1 To UBound(v, 1)
If r.Value = v(i, 1) Then
r.Offset(, 1).Value = v(i, 2)
r.Offset(, 1).Value = v(i, 4) ↑
r.Offset(, 2).Value = v(i, 5) ここは不要
r.Offset(, 2).Value = v(i, 6) ↓
Exit For
End If
Next
Next
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Dim j As Integer
For i = 1 To UBound(v, 1)
On Error Resume Next
j = Application.Match(v(i, 1), sh2.Range("A3:A33"), 0)
On Error GoTo 0
With sh2
If j > 0 Then
.Range("A2").Offset(j, 2).Value = v(i, 2)
.Range("A2").Offset(j, 2).Value = v(i, 4)
.Range("A2").Offset(j, 2).Value = v(i, 5)
.Range("A2").Offset(j, 2).Value = v(i, 6)
End If
End With
Next
直近のコードはシート２への転送がうまくいくかだけのチェック用です。 また、作業がだぶってますので、不要部分を削除願います。 こちらで検証が出来ないので、結果を報告して下さい。 （じゅんじゅん）
表題とは離れてしまいますが シート２に、名前&日付をキーにして B3以降に表示させる式を作っておいて(SUMPRODUCT関数等) マクロで 1.該当月の重複しない名前リストを作成 2.B1セルに次々に入力しながら印刷 と言うのでは駄目ですかね？
月ごとに人数分シートの入ったブックを作るのではなく 1のリストをどこかに出力しておいて、名前を定義し 入力規則でB1セルから選択できるようにしておき Sheet2に「年」と「月」を入力するセルを設けておけば （Sheet2,A列の日付、B1セル入力規則の名前と連動） ブックやシートの量産も避けられるような気がします。
データ量が多くて、計算に時間がかかるようであれば 「先に今月分のデータのみにする」 と言う作業をやっておいても良いような気がします。
現在行おうとなさっている方法とは、少し違うので ご参考程度に。
(HANA)
ウザイかも知れませんがここまでやらないとわからなかったので… コード再掲載します。
Sub Test12()
'変数の型を宣言！
Dim Dic As Object
Dim key As Variant
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim r As Range
Dim mon1 As Date, mon2 As Date
Dim v As Variant
Dim i As Integer
'あらかじ日付の範囲を決めておく… （変更できるようにするならセル番地指定なのかな？）
mon1 = DateSerial(Year(Date), Month(Date) - 1, 26) '先月26日
mon2 = DateSerial(Year(Date), Month(Date), 25) '今月25
'画面の更新を止めちゃう Application.ScreenUpdating = False
Set sh1 = Worksheets("date")
Set sh2 = Worksheets("Care")
Set Dic = CreateObject("Scripting.Dictionary")
'シート１の氏名の重複せずに格納する？
With sh1
For Each r In .Range(.[c2], .Cells(Rows.Count, "c").End(xlUp))
Dic(r.Value) = Empty
Next
End With
'格納した氏名（要素）の数だけ繰り返す For Each key In Dic.keys
'ここからシート１で作業しますよって
With sh1
'データから必要な期間だけをフィルタ
.Range("A1").AutoFilter 1, ">=" & mon1, xlAnd, "<=" & mon2
'氏名（要素）でフィルタ
.Range("A1").AutoFilter Field:=3, Criteria1:=key
'絞った情報をコピって
.Range("A1").CurrentRegion.Copy
'コピったものをシート２へ値ペタ
sh2.Range("A50").PasteSpecial Paste:=xlPasteValues
'そんでもってフィルタ解除
.AutoFilterMode = False
'シート１での作業はおしまい
End With
'今度はシート２に氏名をカキコ
With sh2
.Range("b1").Value = key
End With
'ｖで使用する領域をきめとく（さっき貼り付けた四辺を参照範囲にする）
v = sh2.Range("A50").CurrentRegion.Value
'これから使う変数の宣言！ Dim j As Integer
'一定の数だけ繰り返す（変数iが１から参照範囲のｖの最大値までの回数） For i = 1 To UBound(v, 1)
'エラーの場合の指定（goto0でthenでnextでループを抜ける）
On Error Resume Next
'条件が一致する行はどこにあるのか… かな？
j = Application.Match(v(i, 1), sh2.Range("A3:A33"), 0)
On Error GoTo 0
'エラーでなければシート２の指定箇所にカキコする With sh2
'ｊの条件が０より大きければ書き込む。そんな判断かな？
If j > 0 Then
'a4を基本に下に何行・右に何列目にvの何行目の何列目を書き込む…だな。
.Range("A4").Offset(j, 1).Value = v(i, 2)
.Range("A4").Offset(j, 2).Value = v(i, 4)
.Range("A4").Offset(j, 3).Value = v(i, 5)
.Range("A4").Offset(j, 4).Value = v(i, 6)
End If
'シート２の作業を終わりにする End With
'一人分の書き込みのループを終わる Next
'新しいワークシートを作る Worksheets.Add After:=Worksheets(Worksheets.Count)
'シート名を氏名にする ActiveSheet.Name = key
Set sh3 = Worksheets(key)
'氏名のシートの任意のセルに氏名を書き込み、シート２の内容をコピペする。
With sh3
.Range("b1").Value = key
End With
With sh2
.Range("A1").CurrentRegion.Copy Destination:=Worksheets(key).Range("a1")
End With
'一人目の作業が終了したことのメッセージボックス告知 MsgBox "ひとりめ終わり"
'一人分のループ作業終了で、また振り出しに戻る Next
'ちゃんと元通りに戻して画面を更新させて… Set Dic = Nothing Set sh1 = Nothing Set sh2 = Nothing Set sh3 = Nothing Application.ScreenUpdating = True
'お疲れ様でした End Sub
とまあこんな感じですが たぶんまだ解釈がまちがってるのかなぁ？
それと５０行目のデータはあえて別シートに飛ばして参照して使用後は削除でもいいですよね。 まだ、このコードだとどんどんシート２に上書きしていくので毎回リセット（消去）もしないといけませんね （太陽）
(HANA)様ご意見ありがとうございます
>1.該当月の重複しない名前リストを作成 >2.B1セルに次々に入力しながら印刷 >と言うのでは駄目ですかね？ それだと氏名をマクロで書き込んで飛ばすだけですか？ 欲張りなのでそれもちょっとやってみたいと思います。 （太陽）
簡単なサンプルを載せておきます。 Sheet1 [A] [B] [C] [D] Sheet2 [A] [B] [C] [D] [1] 日付 氏名 番号 数量 [1] 氏名 い 月→ 9 [2] 7月1日 あ 1 10 [2] [3] 7月2日 あ 2 20 [3] 日付 番号 数量 [4] 7月3日 あ 3 30 [4] 9月1日 10 100 [5] 8月1日 い 4 40 [5] 9月2日 11 110 [6] 8月2日 い 5 50 [6] 9月3日 12 120 [7] 8月3日 い 6 60 [8] 8月1日 あ 7 70 [9] 8月2日 あ 8 80 [10] 8月3日 あ 9 90 [11] 9月1日 い 10 100 [12] 9月2日 い 11 110 [13] 9月3日 い 12 120
Sheet2 D4 →D6までコピー =DATE(2007,$D$1,ROW(A1)) B4 →B4:C6にコピー =SUMPRODUCT(($B$1=Sheet1!$B$1:$B$100)*($A4=Sheet1!$A$1:$A$100),Sheet1!C$1:C$100)
D1に「月」を半角数字で入力すると、A列の日付が変わります。 B1に「氏名」を入力すると、該当する数字が表示されます。 ただし、データが複数ある場合は、合計された結果になります。
この様にしておくと、マクロでB1に氏名を書き込みながら印刷。 D1に月を、B1に氏名を入力すると 過去のデータを個人毎に確認出来ますので その目的で別ブックを作成して居られるのなら、作成不要になると思います。
あくまでも「簡単なサンプル」程度ですが。 使えそうであれば、もう少し詰めて考えるのが良いと思います。
(HANA)
＞それだと氏名をマクロで書き込んで飛ばすだけですか？ マクロで行う印刷工程自体は 'シート１の氏名の重複せずに格納する？ '格納した氏名（要素）の数だけ繰り返す '今度はシート２に氏名をカキコ 印刷する '一人分の書き込みのループを終わる で済むと思います。
もしも計算に時間がかかるようでしたら、 最初に「印刷したい所だけのデータにする」の行程を入れて 式を簡単にすればよいかもしれません。
いずれにしても、今後のために リストを書き出す。 は、やるのが良いと思いますが。
(HANA)
シート２のＤ列は使用しなくても…というよりどこにあっても可能ですか？ とりあえず今作成しているものが当初とは別の用途のものにはまったので 完成させて、本題のファイルは(hana)さんの方法でやってみたいと考えています。
'格納した氏名（要素）の数だけ繰り返す For Each key In Dic.keys
'ここからシート１で作業しますよって
With sh1
'データから必要な期間だけをフィルタ
.Range("A1").AutoFilter 1, ">=" & mon1, xlAnd, "<=" & mon2
'氏名（要素）でフィルタ
.Range("A1").AutoFilter Field:=3, Criteria1:=key
'絞った情報をコピって
.Range("A1").CurrentRegion.Copy
'コピったものをシート２へ値ペタ
sh2.Range("A50").PasteSpecial Paste:=xlPasteValues
'そんでもってフィルタ解除
.AutoFilterMode = False
'シート１での作業はおしまい
End With
'今度はシート２に氏名をカキコ
With sh2
.Range("b1").Value = key
End With
'ｖで使用する領域をきめとく（さっき貼り付けた四辺を参照範囲にする）
v = sh2.Range("A50").CurrentRegion.Value
'これから使う変数の宣言！ Dim j As Integer
'一定の数だけ繰り返す（変数iが１から参照範囲のｖの最大値までの回数） For i = 1 To UBound(v, 1)
'エラーの場合の指定（goto0でthenでnextでループを抜ける）
On Error Resume Next
'条件が一致する行はどこにあるのか… かな？
j = Application.Match(v(i, 1), sh2.Range("A4:A34"), 0)
On Error GoTo 0
'エラーでなければシート２の指定箇所にカキコする With sh2
'ｊの条件が０より大きければ書き込む。そんな判断かな？
If j > 0 Then
'a4を基本に下に何行・右に何列目にvの何行目の何列目を書き込む…だな。
.Range("A3").Offset(j, 1).Value = v(i, 2)
.Range("A3").Offset(j, 2).Value = v(i, 4)
.Range("A3").Offset(j, 3).Value = v(i, 5)
.Range("A3").Offset(j, 4).Value = v(i, 6)
End If
'シート２の作業を終わりにする End With
'一人分の書き込みのループを終わる Next
上記の部分だけ変更してスタイルぴったし！ってな感じですが なぜか１回目の書き込みの最終行がうまくいかないのと、
２回目（二人目）の書き込みが２８行目から始まりというか２８行目に どんどん上書き…泣 ３回目（三人目）以降も同じ…
また私はきっと基本的なお馬鹿をしてると思いつつブレークポイントと 本人ブレークの嵐ですよ。さっぱりわからない。 助けてください（太陽）
>なぜか１回目の書き込みの最終行がうまくいかないのと、 エラーが出るのでしょうか？
>２回目（二人目）の書き込みが２８行目から始まりというか２８行目に
>どんどん上書き…泣
j = Application.Match(v(i, 1), sh2.Range("A4:A34"), 0)
j が２８に固定されていると言う事でしょうか？
(じゅんじゅん)
今度はjが0に固定されて書き込まなくなりました。 （太陽）
sh2.Range("A50").CurrentRegion.Value
この範囲内のデータは正しく転記されてますか？
For Each key In Dic.keys の次に
sh2.Range("A50").CurrentRegion.ClearContents を追加してみて下さい。
(じゅんじゅん)
すみませんでした。スタイルを気にしすぎてセルの書式をいじったからでした。 ほぼ完璧なのですが現在５０人ほどのデータで試したのですが何人かのシートに シート１の１行目の見出しが転記されます。なぜでしょう？
v = sh2.Range("A50").CurrentRegion.Val ←これをa51にしましたが無理でした？
（太陽）
全員５０行目に見出しがありますよね？
>For i = 1 To UBound(v, 1)
⇒ For i = 2 To UBound(v, 1)
^^^
では、どうでしょうか？
(じゅんじゅん)
（じゅんじゅん）さま 大変ありがとうございました。完璧な求めた動作になりました。 私の解釈も自分でもよくわからないままの部分が多々あります。 ここで教えていただく皆さんにご迷惑をかけないで済むように 書籍やネットで… ここの過去ログも勉強していきます。
サイト管理者さま またわからないことがあると思いますがその節はお願いいたします。 長々とみっともないログをすみませんでした。
(HANA)さま いただいた提案はもう一つのファイルにて作成していきます。 またどうしても不明な点があれば新たに建ててご教授願います。
（太陽）
コードの方は完成しましたか？ （完成するのを待っていたのですがね。）
＞シート２のＤ列は使用しなくても…というよりどこにあっても可能ですか？ どこにあっても可能です。 使用するかしないかは、運用方法によります。
私は「別ブックを作らない」方法を提案しています。 そのためには、過去のデータを簡単に表示できる必要があります。 「月」と「氏名」を設定する事で過去のデータを簡単に表示できる様になります。 印刷する事だけが目的で有れば、印刷前にA列の日付を 印刷したい範囲の日付に変更する事にすれば、年月情報を入れるセルは不必要です。
SUMPRODUCT関数が使えるか（データ量的に）を確認して下さい。 それから、運用方法をどうするのか決定してください。
(HANA)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.