[[20070821022325]] 『マクロで転記したいのですが』(太陽) >>BOT

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『マクロで転記したいのですが』(太陽)
 excel2003 winxp

 シート構成が2枚で1枚目がデータのシートです。
 2枚目は出来上がっているプリントのためのシートです。
 単純な成績管理のようなものです。

 人数が多くなり一人でフィルターを掛けてコピー&ペーストが
 発表の日までに間に合わなくなってしまって苦労なので
 マクロでどうかと考えたのですが、
 複数回繰り返したり、氏名の数だけという条件が
 マクロの記録ではわかりません。

 シート1
 a    b    c    d
 日付 氏名 番号 数量

 シート2
 a     b     c     
 日付 番号 数量

 上記のようなシート構成になってます。
 シート2の日付は1か月分入力されています。

 シート1のb列をオートフィルタで一人づつ選択して
 その人間のデータのシート1の日付とシート2の日付とが一致したら
 シート1のc・d列の数値をシート2のb・c列に抽出したデータの
 数だけ転記させたいのです

 その後、上記の動作をシート1の氏名の数だけ繰り返したいのですが
 上記の説明で大丈夫でしょうか?

 どなたかよろしくお願いいたします。


 シート1で氏名だけオートフィルターするのではなく、氏名と日付で抽出して転記すれば楽なように
 思いますけど。

 ⇒シート2の日付は1か月分入力されています。
 結局は開始日と終了日があるんですよね?
 氏名とあわせて条件として与えればいいのかな〜と感じますが。(あくまで案ですが)
 (じゅんじゅん)

 >結局は開始日と終了日があるんですよね?
 そうです。一か月の集計になっています

 >シート1で氏名だけオートフィルターするのではなく、氏名と日付で抽出して転記すれば楽なように
 思いますけど。
 氏名だけでも何十人もいるので複雑になりませんか?

 (太陽)

 >氏名だけでも何十人もいるので複雑になりませんか?
 シート2に表示したいのは、ある人のある期間についてではないでしょうか。
 ならば、シート1で”ある人”だけを抽出して、シート2の”ある期間”に該当する云々より、
 楽かな?と思った次第です。

 >複数回繰り返したり、氏名の数だけという条件が
 繰り返してシート2に羅列するのか、抽出毎に印刷するのか?
 シート2には”氏名”がないので、どうされるかはわかりませんが、
 一案として頂ければ。
 (じゅんじゅん)

 説明が足りなくてすみませんでした。

 ”ある人”というキーワードがバイトさんの氏名でよく入れ替わるので固定化できません。
 今月なら今月に存在する氏名の分だけ抽出したいのがまず1点。

 複数回繰り返すのは、aさんをシート2に転記したらプリントして、さらに別のブック
 に氏名ごとのシートを作成して保存。その後シート2のb列とc列をクリアして・・・
 というのをシート1のa列の名前の数だけ繰り返すという意味です。

 シート2には

   a     b     c   
 1 氏名
 2  
 3 日付 番号 数量

 こんな感じで氏名がございます。省略してしまってすみません。
 (太陽)


[[20070730174656]] 『VBA-データ抽出、転送方法』(aoki)
 ご参考になりませんか?
 (じゅんじゅん)

 すみません。少しご説明願えませんか?

 まず、期待以上の結果でした。
 このマクロを使用した結果、新しく作成される氏名毎のシートに発生する
 氏名の列、私の今回使用したデータの場合3列目を氏名列にして
 新しいシートにも3列目に氏名列が出来てしまったのですが、
 1・2・4・5列目だけの転記って可能ですか?6列目からは
 転記先のシートに数式が入っているので…

 それとですね、飛ばした先に書式設定されているものが列幅やその他が
 狂うのであくまでも値貼り付けのような結果などは可能ですか?

 それと、どこでどんな実行をしているのか簡単に説明していただけますか?
 お時間があればで結構です。

 私ももう一回ブレークポイントってのを全部にやって観察してみます。
 (太陽)

 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")
 この行ですが仮に一番右下のセルが空白であった場合
 例 5列のうち4列目までしか入力の無いセルがたまたまあった場合。
 どうなりますか?


 >>.Range("A1").CurrentRegion.Copy Destination:=Worksheets(key).Range("a3")
 >この行ですが仮に一番右下のセルが空白であった場合
 >例 5列のうち4列目までしか入力の無いセルがたまたまあった場合。
 >どうなりますか?

 .Range("A1").CurrentRegion この範囲内であれば貼り付くと思いますよ。
 参考URL
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列に日付が1ヶ月分入っている
 シート2にこの個人で分けられたデータを転記していくのは自動で行うのはどうでしょうか?

 また、この場合新規に氏名でシートを作成していくのですが
 理想の順番だと

 シート1から1人目のデータをシート2のカレンダーに一致する日付の分だけ転記する
  ↓
 転記したものを(シート2)印刷する
  ↓
 シート2の内容をシートごとその1人目の氏名の名前でシートを作成しコピーする
  ↓
 シート2をデータを転記したところだけ削除して元に戻す
  ↓
 シート1から今度は2人目のデータを…

 とこのような動作ををデータの人数分だけ繰り返したいのです。

 分ける過程で組み込めないものかと考えたのですが難しそうですね。
 (太陽)


 文章で説明するのって本当に難しいですね。
 以前にあったアップローダーって今は使えないのですね?
 (太陽)

 例えばこの様な表があったとして、
     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) '今月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列の値にあわせる事もないと思います。
 試してみて下さい。
 (じゅんじゅん)

 説明不足を繰り返してすみません。
 以下の通りの書式がシート2には用意されています

 シート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

 シート1のデータの中からフィルターで一人づつ選択してフィルターをかけ、かけた人間の氏名を
 転記して日付条件がが一致すればその日付のB列以降を転記する。(データーは何か月分もあるものなので)
 必要なのは一月分なのですが、というものです。その作業を人数分繰り返すのです。

 いつもの作業でフィルターを使って一人づつコピーしていて、しかもデータのシートのように
 飛び飛びでぎっしりでなくカレンダーの中で出ている日だけ貼り付けて…なんでこんな要求するかなぁ

 しかも人数分ですが毎月人間は入れ替わるし、で自動で出来ないかと単純に考えてしまったわけです
 無理言ってすみません(太陽)


 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)
'--------------------------------------------------------------------
'ここにシート2のスタイルをコピペして
'--------------------------------------------------------------------
     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
 この様なイメージでは駄目ですか?(太陽)

 ファイルをコピーし、シート2が存在するとして下記コードがうまく動くかどうかですが。
 (7月の日付があると仮定した場合)

 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) '先月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

 シート2の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, 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

 直近のコードはシート2への転送がうまくいくかだけのチェック用です。
 また、作業がだぶってますので、不要部分を削除願います。
 こちらで検証が出来ないので、結果を報告して下さい。
 (じゅんじゅん)

 表題とは離れてしまいますが
 シート2に、名前&日付をキーにして
 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")

 'シート1の氏名の重複せずに格納する?
 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

      'ここからシート1で作業しますよって
      With sh1

           'データから必要な期間だけをフィルタ
           .Range("A1").AutoFilter 1, ">=" & mon1, xlAnd, "<=" & mon2

           '氏名(要素)でフィルタ
           .Range("A1").AutoFilter Field:=3, Criteria1:=key

           '絞った情報をコピって
           .Range("A1").CurrentRegion.Copy

           'コピったものをシート2へ値ペタ
           sh2.Range("A50").PasteSpecial Paste:=xlPasteValues

           'そんでもってフィルタ解除
           .AutoFilterMode = False

      'シート1での作業はおしまい
      End With

      '今度はシート2に氏名をカキコ
      With sh2
           .Range("b1").Value = key
      End With

 'vで使用する領域をきめとく(さっき貼り付けた四辺を参照範囲にする)
 v = sh2.Range("A50").CurrentRegion.Value

 'これから使う変数の宣言!
 Dim j As Integer

 '一定の数だけ繰り返す(変数iが1から参照範囲のvの最大値までの回数)
 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

 'エラーでなければシート2の指定箇所にカキコする
 With sh2

    'jの条件が0より大きければ書き込む。そんな判断かな?
     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

 'シート2の作業を終わりにする
 End With

 '一人分の書き込みのループを終わる
 Next

 '新しいワークシートを作る
 Worksheets.Add After:=Worksheets(Worksheets.Count)

 'シート名を氏名にする
 ActiveSheet.Name = key

 Set sh3 = Worksheets(key)

     '氏名のシートの任意のセルに氏名を書き込み、シート2の内容をコピペする。
     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

 とまあこんな感じですが
 たぶんまだ解釈がまちがってるのかなぁ?

 それと50行目のデータはあえて別シートに飛ばして参照して使用後は削除でもいいですよね。
 まだ、このコードだとどんどんシート2に上書きしていくので毎回リセット(消去)もしないといけませんね
 (太陽)

 (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)


 >それだと氏名をマクロで書き込んで飛ばすだけですか?
 マクロで行う印刷工程自体は
  'シート1の氏名の重複せずに格納する?
  '格納した氏名(要素)の数だけ繰り返す
	'今度はシート2に氏名をカキコ
	 印刷する
  '一人分の書き込みのループを終わる
 で済むと思います。

 もしも計算に時間がかかるようでしたら、
 最初に「印刷したい所だけのデータにする」の行程を入れて
 式を簡単にすればよいかもしれません。

 いずれにしても、今後のために
  リストを書き出す。
 は、やるのが良いと思いますが。

 (HANA)

 シート2のD列は使用しなくても…というよりどこにあっても可能ですか?
 とりあえず今作成しているものが当初とは別の用途のものにはまったので
 完成させて、本題のファイルは(hana)さんの方法でやってみたいと考えています。

  '格納した氏名(要素)の数だけ繰り返す
 For Each key In Dic.keys

      'ここからシート1で作業しますよって
      With sh1

           'データから必要な期間だけをフィルタ
           .Range("A1").AutoFilter 1, ">=" & mon1, xlAnd, "<=" & mon2

           '氏名(要素)でフィルタ
           .Range("A1").AutoFilter Field:=3, Criteria1:=key

           '絞った情報をコピって
           .Range("A1").CurrentRegion.Copy

           'コピったものをシート2へ値ペタ
           sh2.Range("A50").PasteSpecial Paste:=xlPasteValues

           'そんでもってフィルタ解除
           .AutoFilterMode = False

      'シート1での作業はおしまい
      End With

      '今度はシート2に氏名をカキコ
      With sh2
           .Range("b1").Value = key
      End With

 'vで使用する領域をきめとく(さっき貼り付けた四辺を参照範囲にする)
 v = sh2.Range("A50").CurrentRegion.Value

 'これから使う変数の宣言!
 Dim j As Integer

 '一定の数だけ繰り返す(変数iが1から参照範囲のvの最大値までの回数)
 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

 'エラーでなければシート2の指定箇所にカキコする
 With sh2

    'jの条件が0より大きければ書き込む。そんな判断かな?
     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

 'シート2の作業を終わりにする
 End With

 '一人分の書き込みのループを終わる
 Next

 上記の部分だけ変更してスタイルぴったし!ってな感じですが
 なぜか1回目の書き込みの最終行がうまくいかないのと、

 2回目(二人目)の書き込みが28行目から始まりというか28行目に
 どんどん上書き…泣 
 3回目(三人目)以降も同じ…

 また私はきっと基本的なお馬鹿をしてると思いつつブレークポイントと
 本人ブレークの嵐ですよ。さっぱりわからない。
 助けてください(太陽)

 >なぜか1回目の書き込みの最終行がうまくいかないのと、
 エラーが出るのでしょうか?

 >2回目(二人目)の書き込みが28行目から始まりというか28行目に
 >どんどん上書き…泣 
 j = Application.Match(v(i, 1), sh2.Range("A4:A34"), 0)
 j が28に固定されていると言う事でしょうか?

 (じゅんじゅん)

 今度はjが0に固定されて書き込まなくなりました。
 (太陽)

 sh2.Range("A50").CurrentRegion.Value
 この範囲内のデータは正しく転記されてますか?

 For Each key In Dic.keys の次に
 sh2.Range("A50").CurrentRegion.ClearContents を追加してみて下さい。

 (じゅんじゅん)

 すみませんでした。スタイルを気にしすぎてセルの書式をいじったからでした。
 ほぼ完璧なのですが現在50人ほどのデータで試したのですが何人かのシートに
 シート1の1行目の見出しが転記されます。なぜでしょう?

 v = sh2.Range("A50").CurrentRegion.Val ←これをa51にしましたが無理でした?

 (太陽)

 全員50行目に見出しがありますよね?

 >For i = 1 To UBound(v, 1)
  ⇒ For i = 2 To UBound(v, 1)
            ^^^
 では、どうでしょうか?
 (じゅんじゅん)

 (じゅんじゅん)さま 
 大変ありがとうございました。完璧な求めた動作になりました。
 私の解釈も自分でもよくわからないままの部分が多々あります。
 ここで教えていただく皆さんにご迷惑をかけないで済むように
 書籍やネットで… ここの過去ログも勉強していきます。

 サイト管理者さま
 またわからないことがあると思いますがその節はお願いいたします。
 長々とみっともないログをすみませんでした。

 (HANA)さま
 いただいた提案はもう一つのファイルにて作成していきます。
 またどうしても不明な点があれば新たに建ててご教授願います。

 (太陽)


 コードの方は完成しましたか?
(完成するのを待っていたのですがね。)

 >シート2のD列は使用しなくても…というよりどこにあっても可能ですか?
 どこにあっても可能です。
 使用するかしないかは、運用方法によります。

 私は「別ブックを作らない」方法を提案しています。
 そのためには、過去のデータを簡単に表示できる必要があります。
 「月」と「氏名」を設定する事で過去のデータを簡単に表示できる様になります。
 印刷する事だけが目的で有れば、印刷前にA列の日付を
 印刷したい範囲の日付に変更する事にすれば、年月情報を入れるセルは不必要です。

 SUMPRODUCT関数が使えるか(データ量的に)を確認して下さい。
 それから、運用方法をどうするのか決定してください。 

 (HANA)

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.