[[20190315142148]] 『別シートへのセル内容の転記(毎月4つ下のセルに刀x(ひなた) >>BOT

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

 

『別シートへのセル内容の転記(毎月4つ下のセルに転記したい)』(ひなた)

お世話になっております。
コピー元から特定のセルの数値をコピーして、別シートの特定のセルへの貼付けを行いたいです。
コピー元は全社員の社員番号、金額等が1枚のシートに記入されています。
コピー先は社員ごとのシートとなっており、社員番号2の人は2というシートになります。

こちらは社員番号2番の社員のマクロ
Sub 2()

  Worksheets("Pay").Range("E15").Copy Worksheets("2").Range("F13:H14")
  Worksheets("Pay").Range("E23").Copy Worksheets("2").Range("J13:K14")
End Sub

こちらは社員番号3番の社員用のマクロ
Sub 3()

  Worksheets("Pay").Range("G15").Copy Worksheets("3").Range("F13:H14")
  Worksheets("Pay").Range("G23").Copy Worksheets("3").Range("J13:K14")
End Sub

上記のマクロが社員分あります。。。

毎月データを転記しますが、貼付け先のセルは4つずつ下にずれて転記しなければならないため、毎月このマクロを変えて実行していました。

貼付け部分だけを記しますと下記のような感じに変更していたということです。
Range("F13:H14") → Range("F17:H18")
Range("J13:K14") → Range("J17:K18")

これを社員分やっていましたが、毎月マクロを更新してセルを変更するのが大変です。。。
なんとか自動で4つ下のセルを取得してペーストできないものかというご相談です。

マクロ初心者ですので、できればご教授いただける場合は解説を少しいただけると助かります。

お手数をおかけいたしますが、よろしくお願いいたします。

< 使用 Excel:Excel2007、使用 OS:Windows10 >


同じ表で、もし次のマクロ作成時に14行以降にデータが入っていないのであれば
F〜H列は
range(cells(cells(rows.count,6).end(xlup).row + 3 ,6),cells(rows.count,6).end(xlup).row + 3 ,8))
J〜K列は
range(cells(cells(rows.count,10).end(xlup).row + 3 ,10),cells(rows.count,6).end(xlup).row + 3 ,11))
を使えば良いのではないかと思います。
(げん) 2019/03/15(金) 14:44

間違えてしまいました。
F〜H列は
range(cells(cells(rows.count,6).end(xlup).row + 3 ,6),cells(rows.count,6).end(xlup).row + 4 ,8))
J〜K列は
range(cells(cells(rows.count,10).end(xlup).row + 3 ,10),cells(rows.count,6).end(xlup).row + 4 ,11))
でした。
(げん) 2019/03/15(金) 14:46

げんさん
ありがとうございます。
ただ、コピー先の各セルの60行目に合計金額が入るので、最終行を取得する方法だと難しいです。
先に言っておけばよかったです、申し訳ありません。
(ひなた) 2019/03/15(金) 14:57

そうでしたか。
それでは月ごとの処理のようなのでmonthから得られる数字をmodで修正するのはいかがでしょうか。

例えば3月始まりの2月終わりで13→17→21と4ずつ増えていく式であれば
(A1セルに日付が入ってると仮定します)
f〜h
range(cells(month(cells(1,1).value)+9 mod 12 +1 )*4+1,6),cells(month(cells(1,1).value)+9 mod 12 +1 )*4+1,8)
j〜k
range(cells(month(cells(1,1).value)+9 mod 12 +1 )*4+1,10),cells(month(cells(1,1).value)+9 mod 12 +1 )*4+1,11)
(げん) 2019/03/15(金) 15:08


すみません。また間違えていました。
初期値が13なので+1ではなく+9です。
f〜h
range(cells(month(cells(1,1).value)+9 mod 12 +1 )*4+9,6),cells(month(cells(1,1).value)+9 mod 12 +1 )*4+1,8)
j〜k
range(cells(month(cells(1,1).value)+9 mod 12 +1 )*4+9,10),cells(month(cells(1,1).value)+9 mod 12 +1 )*4+1,11)
(げん) 2019/03/15(金) 15:11

げんさん
ありがとうございます。
コンパイルエラーになってしまいましたが、
Sub 2()
  Worksheets("Pay").Range("E15").Copy Worksheets("2").Rangerange(cells(month(cells(1,1).value)+9 mod 12 +1 )*4+1,6),cells(month(cells(1,1).value)+9 mod 12 +1 )*4+1,8) 
  Worksheets("Pay").Range("E23").Copy Worksheets("2").Range(cells(month(cells(1,1).value)+9 mod 12 +1 )*4+1,10),cells(month(cells(1,1).value)+9 mod 12 +1 )*4+1,11) 
End Sub
こういうことで合っていますでしょうか?
理解が悪く申し訳ありません・・・。
(ひなた) 2019/03/15(金) 15:35

横からですが、ずれる数が固定(1月あたり4行)されていて、条件(何月か)が決まってるならそう悩む話でもないのでは?

 基準月(年初め)が分かりませんけど、1月始まりとした場合
 1月 ・・・・ 0行ずれる(ずれない)
 2月 ・・・・ 4行ずれる( (2-1) × 4 行下がる)
  3月 ・・・・ 8行ずれる( (3-1) × 4 行下がる)
       ・
       ・
       ・

ですよね?
社員番号もシート名の部分に反映されれば良さそうですから、こんな感じのアプローチもありなのでは?

    Sub めいん()
        Dim 処理月 As Long
        Dim 社員番号 As String

        処理月 = InputBox("何月の処理ですか?")
        社員番号 = Format(InputBox("社員番号を入力してください"), "00")

        Call 処理部(社員番号, ((処理月 - 1) * 4))

    End Sub
    '------------------------------------------------------------------
    Sub 処理部(シート名 As String, ずれ数 As Long)
        With Worksheets("Pay")
            .Range("E15").Copy Worksheets(シート名).Range("F13:H14").Offset(ずれ数)
            .Range("E23").Copy Worksheets(シート名).Range("J13:K14").Offset(ずれ数)
        End With
    End Sub

※この程度で十分という意味ではありません。私の分かる範囲での一例です。
※テストしてないのでミスっていたらごめんなさい。

(もこな2) 2019/03/15(金) 15:57


もこな2さん
ありがとうございます。
ボックスが出てくるタイプのマクロは敷居が高そうで作ったことがなくて、思いもつきませんでした!
実行してみたところ、実行時エラー9 インデックスが有効範囲にありません と出てしまいました。
無知なので質問させていただきたいのですが、社員番号は00とあるので2桁で入力するということですか?
社員番号とシート名はどこで結びついているのでしょうか?
社員番号02と入力した際、シート名も02にしないといけないのでしょうか?
よろしければ教えていただきたいです
(ひなた) 2019/03/15(金) 16:13

Sub 改2()
  Dim rw As Long
  rw = Worksheets("2").Range("F60").End(xlUp).Row + 3
  Worksheets("Pay").Range("E15").Copy Worksheets("2").Range("F" & rw & ":H" & rw + 1)
  Worksheets("Pay").Range("E23").Copy Worksheets("2").Range("J" & rw & ":K" & rw + 1)
End Sub
(mm) 2019/03/15(金) 16:37

mmさん
ありがとうございます。
こちらも試してみましたが、結合されたセルの一部を変更することはできませんと3行目でエラーが出てしまいました。。。
(ひなた) 2019/03/15(金) 16:51

>実行時エラー9 インデックスが有効範囲にありません と出てしまいました。
おっとごめんなさい。余計なことをしてますね。
とりあえず
 誤 社員番号 = Format(InputBox("社員番号を入力してください"), "00")
 正 社員番号 =InputBox("社員番号を入力してください")

に修正してください。

ちなみにFormatの部分では、

  「1」という【数値】を入力 →「01」に変換
 「12」という【数値】を入力 →「12」に変換

というように、1桁の数値が入力された場合に桁埋めして出力するように設計していました。
(シート名が01、02となっているのと勘違いしていました。)

>社員番号とシート名はどこで結びついているのでしょうか?
一度、ステップ実行をしてみて、各変数に何が格納されるのかを見ながら研究してみてください。

>社員番号02と入力した際、シート名も02にしないといけないのでしょうか?
仮に、「社員番号02」と入力されるのであれば、シート名も「社員番号02」でないとダメです。

なお、今回、社員番号を「2」と入力されたのであれば、

 (1)Format関数で、「02」に変換される
 (2)String型の変数「社員番号」に代入されることにより【文字列】の「02」として保持される
 (3)Worksheets(シート名) の「シート名」の部分が「02」という文字列と解釈される
 (4)Worksheets("02") に該当するものが存在しないため実行時エラーが発生   ← 今ココ

という状態になっていると推測します。

このほか、
>ボックスが出てくるタイプ〜
とのことですが、別にInputboxでないとダメな理由はないので、そこは適宜変えてください。

以下蛇足ですが、通常、一人だけの処理というのは無いと思いますから、月はともかくとしてFor〜Nextステートメントなどで社員番号そのものや、別途リストを用意して対象の行番号を増やしながらループさせるというアプローチにすると楽ちんなのではないかと思います。

    Sub さんぷる()
        Dim 処理月 As Long
        Dim 社員番号 As Long

        処理月 = InputBox("何月の処理ですか?")

        Stop '←ブレークポイントのかわり

        '▼社員番号1〜10を連続処理
        For 社員番号 = 1 To 10
            With Worksheets(CStr(社員番号))
                Worksheets("Pay").Range("E15").Copy .Range("F13:H14").Offset((処理月 - 1) * 4)
                Worksheets("Pay").Range("E23").Copy .Range("J13:K14").Offset((処理月 - 1) * 4)
            End With
        Next 社員番号

    End Sub

(もこな2) 2019/03/15(金) 18:30


もこな2さん
丁寧にありがとうございます。
Worksheets("Pay").Range("E15").Copy .Range("F13:H14").Offset((処理月 - 1) * 4)

色々とやってみたのですが、For〜文の行にブレークポイントを入れて、社員番号2が選択されていることを確認したあと、上記の行で結合されたセルの一部を変更することはできませんとエラーになってしまいました。
貼付け先が結合セルであることがまずいのでしょうか?

For〜Next構文で社員ごとに毎回マクロを実行しなくてもいいのはとても便利ですね。数字を入れていくとか、そういう単純なことにしか使ったことがないので、大変参考になります。
(ひなた) 2019/03/18(月) 12:00


 ひなたさん
 それ以前に、もこな2さんのコードでは、常にE15がコピーされていくことになります。
 なので、以下について教えてください。
 1)Payシートの表構成
   今わかっているのは、たぶんこんな感じなんだろうという程度です。
   結合セルがあるなら、教えてください。
     |[B]     |[C]|[D]|[E]   |[F]|[G]   |[H]|[I]   |[J]|[K]   
 [14]|社員番号|?  |   |     2|   |     3|   |     9|   |    20
 [15]|        |100|   |\1,000|   |\3,000|   |\5,000|   |\7,000
 [16]|        |   |   |      |   |      |   |      |   |      
 [17]|        |   |   |      |   |      |   |      |   |      
 [18]|        |   |   |      |   |      |   |      |   |      
 [19]|        |   |   |      |   |      |   |      |   |      
 [20]|        |   |   |      |   |      |   |      |   |      
 [21]|        |   |   |      |   |      |   |      |   |      
 [22]|        |   |   |      |   |      |   |      |   |      
 [23]|        |200|   |\2,000|   |\4,000|   |\6,000|   |\8,000

 2)月が替わっても、E15セルを社員番号ごとのシートに張り付ける、という認識でよろしいですね?
 3)payシートには月を特定する文字は入っていませんか?
 4)社員番号ごとのシート構成を教えてください。
   今わかっているのは、F・J列に張り付け、結合セルがあるだろうという推測だけです。
   月の始まりもわかっていません。
   13行目は何月なんですか?
     |[E]  |[F]   |[G]|[H]|[I]|[J]   
 [13]|1月?|\9,999|   |   |   |\9,999
 [14]|     |      |   |   |   |      
 [15]|     |      |   |   |   |      
 [16]|     |      |   |   |   |      
 [17]|2月?|\1,000|   |   |   |\2,000
 [18]|     |      |   |   |   |      
 [19]|     |      |   |   |   |      
 [20]|     |      |   |   |   |      

 5)社員ごとのシート名を教えてください。
   Payシートと同じならそれで構いません。
(稲葉) 2019/03/18(月) 12:40

>貼付け先が結合セルであることがまずいのでしょうか?
はい。まずいです。
基本的に手作業でやってみてできないことは、マクロでもできません。

出力先が結合しているという情報とコードから推測するに、

 Payシートの「E15」セルの【値】 → 対応する社員番号のシートのF13:H14が【結合されたセル】の【値】にしたい
 Payシートの「E23」セルの【値】 → 対応する社員番号のシートのJ13:K14が【結合されたセル】の【値】にしたい

ということだったりしませんか?
その場合、【コピー】せず(書式等は貼付の必要が無く)、ただの【転記】でよいのであれば

    Sub さんぷる2()
        Dim 処理月 As Long
        Dim 社員番号 As Long

        処理月 = InputBox("何月の処理ですか?")
        Stop '←ブレークポイントのかわり

        '▼社員番号1〜10を連続処理
        For 社員番号 = 1 To 10
            With Worksheets(CStr(社員番号))
                .Range("F13").Offset((処理月 - 1) * 4).Value = Worksheets("Pay").Range("E15").Value
                .Range("J13").Offset((処理月 - 1) * 4).Value = Worksheets("Pay").Range("E23").Value
            End With
        Next 社員番号

    End Sub

のように、結合セルの左上にあたるセルのValueプロパティに、データ元セルのValueプロパティを参照させるというアプローチも使えそうに思います。

(もこな2) 2019/03/18(月) 13:02


>それ以前に、もこな2さんのコードでは、常にE15がコピーされていくことになります。
あっ本当だ。社員コードが2の人と、3の人で参照【列】が違うんですね。
稲葉が確認されていることの答えを待ってからの方が良さそうですね。

すみませんが、「2019/03/18(月) 13:02」のものは無視してください。

(もこな2) 2019/03/18(月) 13:14


稲葉さん
ありがとうございます。
下記、お答えいたします。
Payという通り、給与計算表になっています。
貼付け先は各社員の源泉徴収簿となっています。シートは社員番号になっております。
1)Payシートの表構成 → おおまかそんな感じです。
2)月が替わっても、社員2はE15セルを2というシートに貼り付けます
          社員3はG15セルを3というシートに貼り付けます
3)payシートには月を特定する文字は入っていませんか?
  →毎月給与支払い月を書き換えて使用しています。
4)社員番号ごとのシート構成を教えてください。
   今わかっているのは、F・J列に張り付け、結合セルがあるだろうという推測だけです。
   月の始まりもわかっていません。
   13行目は何月なんですか?
       |[E]  |[F〜H]|[I]|[J〜K]|   
 [ 9〜10]|1月  |\9,999|   |\8,800|
 [11〜12]|     |      |   |      |
 [13〜14]|2月  |\9,999|   |\8,800|

5)社員ごとのシート名を教えてください。→社員番号1桁なので、2、3、5・・・という感じです。
ちなみに4は欠番です。
(ひなた) 2019/03/18(月) 13:22


もこな2さん
ありがとうございます。

仰る通り、ただの【転記】です。
元々のマクロもただただ、転記することを目的に社員ごとに作っていたものです。
分かりにくくて申し訳ありません。
参考になるか分からないのですが、コピー元のE15やG15は合計金額で数式が入っています。
でもそれでも単純なマクロでは転記できていました。
(ひなた) 2019/03/18(月) 13:28


 1)大まかじゃ困るんですけどぉ・・・
 2)1)5)に準じますが、I列のように飛んで社員番号9(4番が欠員なのですよね?)
   とかになったりするわけですよね?
   すると、1から5まで繰り返すと通常は
   C,E,G,I,Kになりますが、社員番号4は欠番なので、社員番号5が社員番号4のセル(Iセル)になるわけですよね?
   Payシートの社員番号と、シート名の社員番号が一致しているという認識でいいんですか?
 3)それはどのセルですか?
 4)F9:H10が結合されて、1月から始まりということですね。

 蛇足ですが、payは請求書の精算かと思ってました。
(稲葉) 2019/03/18(月) 13:41

 エラー処理してないですが、こちらでどうでしょう?
 B13に「月」が入力されている前提です。
    Sub test()
        Dim ws As Worksheet
        Dim m As Long
        Dim c As Long
        Set ws = Sheets("Pay")
        m = Val(ws.Range("B13").Value) * 4 + 5 '1月×4行+5行
        For c = 3 To ws.Cells(14, Columns.Count).End(xlToLeft).Column Step 2
            With Sheets(CStr(ws.Cells(14, c).Value))
                .Cells(m, "F").Value = ws.Cells(15, c).Value
                .Cells(m, "J").Value = ws.Cells(23, c).Value
            End With
        Next c
    End Sub
 Payシート
     |[B]     |[C]   |[D]|[E]   |[F]|[G]   |[H]|[I]   |[J]
 [13]|2月     |      |   |      |   |      |   |      |   
 [14]|社員番号|     1|   |     2|   |     3|   |     5|   
 [15]|金額1   |\1,000|   |\2,000|   |\3,000|   |\4,000|   
 [16]|        |      |   |      |   |      |   |      |   
 [17]|        |      |   |      |   |      |   |      |   
 [18]|        |      |   |      |   |      |   |      |   
 [19]|        |      |   |      |   |      |   |      |   
 [20]|        |      |   |      |   |      |   |      |   
 [21]|        |      |   |      |   |      |   |      |   
 [22]|        |      |   |      |   |      |   |      |   
 [23]|金額2   |\5,000|   |\6,000|   |\7,000|   |\8,000|   

 社員番号5の人
     |[E]|[F]      |[G]|[H]|[I]|[J]      |[K]|[L]
 [9] |1月|\4,000.00|   |   |   |\8,000.00|   |   
 [10]|   |         |   |   |   |         |   |   
 [11]|   |         |   |   |   |         |   |   
 [12]|   |         |   |   |   |         |   |   
 [13]|2月|\4,000.00|   |   |   |\8,000.00|   |   
 [14]|   |         |   |   |   |         |   |   
 [15]|   |         |   |   |   |         |   |   
 [16]|   |         |   |   |   |         |   |   
 [17]|3月|         |   |   |   |         |   |   
(稲葉) 2019/03/18(月) 14:04

稲葉さん
失礼しました!
1)
     |[B]     |[C]|[D]|   [E]   |[F]|   [G]  |[H]|   [I]  |[J]|   [K] 
 [ 2]|支給年月|  |   |2019/1  |   |2019/1  |   | 2019/1 |   |2019/1
 [15]|社員番号|   |   |        2|   |     3  |   |       5|   |       6
 [15]|        |   |   |\200,000 |   |\150,000|   |\300,000|   |\400,000
 [16]|        |   |   |         |   |        |   |        |   |      
 […]|        |   |   |         |   |        |   |        |   |      
 [23]|        |   |   |\ 50,000 |   |\ 30,000|   |\60,000 |   |\80,000         
 [24]|(X15-X23)   |   |\150,000 |   |\120,000|   |\240,000|   |\360,000      
 [25]|        |   |   |\  5,000 |   |\  3,000|   |\  6,000|   |\  2,000      

もう大まかではなく、このままでございます。

2)そもそもPayシートに社員番号4欄はなく、シートも4はございません。

3)各2行目です。(上記の2行目をご参照ください)

4)その通りです。
(ひなた) 2019/03/18(月) 14:06


 ん、月ごとにPayが上書き更新されていくと思っていたのですが、
 人ごとに支給日が違う場合もあるのですか?(退職とか?)
 社員番号2が1月で、社員番号3が2月ってこともあるのですか?

 なければ、
 m = Val(ws.Range("B13").Value) * 4 + 5 '1月×4行+5行
 この部分、自分でちょっと考えてやってみません?

(稲葉) 2019/03/18(月) 14:11


稲葉さん

ありがとうございます。
月ごとに更新で、支給年月日も同じです。余談ですが支給年月日は1列目にドドーンと記載してあります。
あくまでも個人ごとに支給年月が記載してあるだけです。

ちょっと理解しながらやっていきたいと思います、ありがとうございます。
(ひなた) 2019/03/18(月) 14:18


稲葉さん

すみません、わからないので質問させてください。

m = Val(ws.Range("B13").Value) * 4 + 5 '1月×4行+5行
→1か月あたり4行使っているということですよね、+5行がちょっとわかりませんでした

ちなみに、エラーは出ませんでしたが、転記もされませんでした。
お力をお借りできれば助かります。
(ひなた) 2019/03/18(月) 15:45


 最初にVal関数の説明と、何をしているか説明して、
 最後にたぶんこうだろうという回答載せます。

 B13には「1月」という  文字列  が入力されています。
 Val関数は
http://officetanaka.net/excel/vba/function/Val.htm
 こっちよんだほうが早いかも。

 Val(ws.Range("B13").Value) * 4 + 5
 =Val("1月") * 4 + 5
 =1 * 4 + 5
 =4 + 5
 =9(行目)

 (ひなた) 2019/03/18(月) 13:22の回答で、1月は9行目から始まっているとのことなので
 このようにしました。
 B13が「2月」の場合は
 2*4+5 =8+5 =13行目
 になります。

 さて、1列目にドドーンと記載されたデータはもしかして日付型データ(2019/2/1のような)じゃないですかね?
 そうすると、Val関数だとたぶん2019とかなので、転記されてないわけじゃなくて、
 8081行目に何か書かれていると思います。

 じゃあどうすればいいかというと、必要なのは「月」なのでMonth関数を使います。

 A1に2019/2/1と入力されていると仮定して
 m = Month(ws.Range("A1").Value) * 4 + 5
 ではどうでしょう?

(稲葉) 2019/03/18(月) 15:58


稲葉さん

ありがとうございます。
Val関数はなんとなく知っていたのですが、どこを取得しているのかわかりませんでした…すみません。
そして、Ctrl+↓で見てみましたが、セルはすべて空白でした・・・、つまり何も書かれていないようです。
一応、Month関数を使うverも実行してみたのですが、変わらずでした・・・
(ひなた) 2019/03/18(月) 16:44


 (稲葉) 2019/03/18(月) 14:04
 のテスト環境だと問題ないので、あとはご自身で頑張ってもらうしかないですね。
 ステップ実行(F8)で一つずつ調べてみてください。

 それでもわからなければ、下記コードで個人情報に当たらない範囲でなるべく修正せずにこちらに投稿してください。
    Sub SheetlayoutToClipBord()
        '=====================================================
        ' 投稿用シートレイアウトをクリップボードに取得
        '              作成者(momo)
        '
        ' BrkStr:列間の文字列 初期値は「|」
        ' DataObjectID:DataObjectのLate Binding用(変更不可)
        ' http://www.excel.studio-kazu.jp/kw/20110209184943.html
        '=====================================================
        Const BrkStr       As String = "|"
        Const DataObjectID As String = "1C3B4210-F441-11CE-B9EA-00AA006B1A69"
        Dim myRng          As Range
        Dim rngFormula     As Range
        Dim rngBuf         As Range
        Dim tbl()          As Variant
        Dim AryTxt()       As String
        Dim StrBuf         As String
        Dim i              As Long
        Dim j              As Long
        Dim cnt            As Long
        Dim AryWidth()     As Long
        Dim LenBuf         As Long
        cnt = 1
        On Error Resume Next
            Set myRng = Application.InputBox("取得したい範囲を選択してください。", Type:=8, Default:=Selection.Address)
        On Error GoTo 0
        If myRng Is Nothing Then
            '何も選択されなかったら、何もしない。
        Else
            'If MsgBox("数式として表示したい範囲はありますか?", vbYesNo) = vbYes Then
                Do
                    On Error Resume Next
                        Set rngBuf = Application.InputBox("数式として表示したい範囲を選択してください。" & cnt & "個目", Type:=8)
                    On Error GoTo 0
                    If Not rngBuf Is Nothing Then
                        If rngFormula Is Nothing Then
                            Set rngFormula = rngBuf
                        Else
                            Set rngFormula = Application.Union(rngFormula, rngBuf)
                        End If
                        cnt = cnt + 1
                    Else
                        Exit Do
                    End If
                    Set rngBuf = Nothing
                Loop 'While MsgBox("さらに数式として表示したい範囲がありますか?", vbYesNo) = vbYes
            'End If
            ReDim tbl(1 To myRng.Rows.Count, 1 To myRng.Columns.Count)
            ReDim AryWidth(1 To UBound(tbl, 2))
            For i = 1 To myRng.Rows.Count
                For j = 1 To myRng.Columns.Count
                    tbl(i, j) = myRng.Cells(i, j).Text
                    If Not rngFormula Is Nothing Then
                        If Not Application.Intersect(myRng.Cells(i, j), rngFormula) Is Nothing Then
                            tbl(i, j) = myRng.Cells(i, j).Formula
                        End If
                    End If
                    LenBuf = Application.Evaluate("LENB(""" & Replace(tbl(i, j), """", vbTab) & """)")
                    If AryWidth(j) < LenBuf Then
                        AryWidth(j) = LenBuf
                    End If
                Next j
            Next i
            ReDim AryTxt(UBound(tbl, 1))
            AryTxt(0) = String(Len(myRng.Rows(myRng.Rows.Count).Row) + 3, " ")
            For i = 1 To UBound(tbl, 2)
                StrBuf = "[" & Split(myRng.Columns(i).EntireColumn.Address(False, False), ":")(0) & "]"
                If AryWidth(i) > Len(StrBuf) Then
                    AryTxt(0) = AryTxt(0) & BrkStr & StrBuf & String(AryWidth(i) - Len(StrBuf), " ")
                Else
                    AryTxt(0) = AryTxt(0) & BrkStr & StrBuf
                    AryWidth(i) = Len(StrBuf)
                End If
            Next i
            For i = 1 To UBound(tbl, 1)
                AryTxt(i) = " [" & myRng.Rows(i).Row & "]" & _
                String(Len(myRng.Rows(myRng.Rows.Count).Row) - Len(myRng.Rows(i).Row), " ")
                For j = 1 To UBound(tbl, 2)
                    LenBuf = Application.Evaluate("LENB(""" & Replace(tbl(i, j), """", vbTab) & """)")
                    If IsNumeric(tbl(i, j)) Then
                        AryTxt(i) = AryTxt(i) & BrkStr & String(AryWidth(j) - LenBuf, " ") & tbl(i, j)
                    Else
                        AryTxt(i) = AryTxt(i) & BrkStr & tbl(i, j) & String(AryWidth(j) - LenBuf, " ")
                    End If
                Next j
            Next i
            With GetObject("new:" & DataObjectID)
                .SetText Join(AryTxt, vbCrLf)
                .PutInClipboard
            End With
            MsgBox "クリップボードにコピーしました。"
        End If
    End Sub

(稲葉) 2019/03/18(月) 16:50


稲葉さん

ありがとうございます。
ステップインしても何も起きず・・・ちょっと分からないのですが、
他の簡易的なマクロを実行すると動くので、もう少し試行錯誤してみます。
丁寧にお教えいただき、ありがとうございました。
(ひなた) 2019/03/19(火) 09:07


 何も起きず・・・じゃなくて、イミディエイトウィンドウで値確かめたりしました?

 例えば
 >m = Val(ws.Range("B13").Value) * 4 + 5 '1月×4行+5行
 が終わった後イミディエイトウィンドウに
 ?m
 と打って、エンター押したときに、希望の数値が出てましたか?

 >       For c = 3 To ws.Cells(14, Columns.Count).End(xlToLeft).Column Step 2
 >           With Sheets(CStr(ws.Cells(14, c).Value))
 >               .Cells(m, "F").Value = ws.Cells(15, c).Value
 この部分に関しても、
 ?ws.Cells(15, c).Address
 とイミディエイトウィンドウに打ち込んで、希望のセル範囲になっているか確認しました?

(稲葉) 2019/03/19(火) 09:38


稲葉さん

ありがとうございます。
お手数をおかけして申し訳ないです。イミディエイトウィンドウ初めて知りました・・・。

ちなみに手直ししたものが下記です。

Sub Copy()

        Dim ws As Worksheet
        Dim m As Long
        Dim c As Long
        Set ws = Sheets("E-Pay")
        m = Month(ws.Range("D1").Value) * 4 + 5 '1月×4行+5行、1月は9行目から
        For c = 5 To ws.Cells(4, Columns.Count).End(xlToLeft).Column Step 2 '社員番号の始まり5列目、4行目の最終列から左方向の入力済み終端セルを取得、1列飛ばし
            With Sheets(CStr(ws.Cells(4, c).Value)) → インデックスが有効範囲にありませんエラー '値を文字型に変更、4行目の社員番号の値
                .Cells(m, "F").Value = ws.Cells(15, c).Value
                .Cells(m, "J").Value = ws.Cells(23, c).Value
            End With
        Next c
    End Sub

イミディエイトウィンドウの結果は
?m では 9が返ってきているのでこちらは大丈夫そうです。
すみません、With〜の行がいまいち理解できていないようです、値を変えたらエラーになってしまいました。
(ひなた) 2019/03/19(火) 10:40


稲葉さん

ちなみに、参考までに・・・
コピー元 Sheet名:E-Pay

     |[A]             |[B]      |[C]         |[D]                 |[E]    |[F]                 |[G]    |[H]                 |[I]    |[J]                 |[K]    |[L]                 |[M]   |[N]    
 [1] |支給年月日:    |         |            |2019年1月25日       |       |                    |       |                    |       |                    |       |                    |      |       
 [2] |支給年月        |         |            |2019年1月           |       |2019年1月           |       |2019年1月           |       |2019年1月           |       |2019年1月           |      |合計   
 [3] |所属            |         |            |所属                |  部 |所属                |  部 |所属                |  部 |所属                |  部 |所属                |  部|       
 [4] |社員番号        |         |            |社員番号            |      2|                    |      7|                    |      3|                    |      8|                    |     5|       
 [5] |氏名            |         |            |氏名                |A      |氏名                |N      |氏名                |K      |氏名                |Y      |氏名                |S     |       

 [15]|                |         |A.小計      |課税分小計          |345,800|課税分小計          |174,500|課税分小計          |252,000|課税分小計          |153,000|課税分小計          |     0|925,300
 [16]|                |非課税分 |通勤手当    |通勤手当            |  4,000|通勤手当            | 20,000|通勤手当            | 16,000|通勤手当            |  4,000|通勤手当            |      | 44,000
 [17]|                |         |            |                    |       |                    |       |                    |       |                    |       |                    |      |       
 [18]|                |         |B.小計      |非課税分小計        |  4,000|非課税分小計        | 20,000|非課税分小計        | 16,000|非課税分小計        |  4,000|非課税分小計        |     0| 44,000
 [19]|                |C.合計A+B|            |支給額合計          |349,800|支給額合計          |194,500|支給額合計          |268,000|支給額合計          |157,000|支給額合計          |     0|969,300

 [24]|差引控除後の金額|         |            |差引控除後の金額    |294,142|差引控除後の金額    |147,126|差引控除後の金額    |214,536|差引控除後の金額    |129,969|差引控除後の金額    |     0|785,773
 [25]|控除額          |所得税   |            |所得税              |  6,520|所得税              |  1,300|所得税              |  5,270|所得税              |  2,260|所得税              |      | 15,350

 [29]|                |F.小計   |            |控除額小計          |   -409|控除額小計          |  3,943|控除額小計          | 10,300|控除額小計          | -1,862|控除額小計          |     0| 11,972
 [30]|差引支給額C-D-F |         |            |差引支給額          |298,551|差引支給額          |163,183|差引支給額          |220,236|差引支給額          |135,831|差引支給額          |     0|817,801

コピー先 
Sheet名:3

     |[D]      |[E]|[F]       |[G]|[H]|[I]|[J]                   |[K]|[L]|[M]                               |[N]|[O]|[P]           |[Q]     |[R]|[S]
 [5] |支給
月日|   |総支給金額|   |   |   |社会保険
料等の
控除額|   |   |社会保険料等
控除後の給与
等の金額|   |   |扶養親族等の数|算出税額|   |   
 [6] |         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [7] |         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [8] |         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [9] |        1| 25|  252,000 |   |   |円 |               37,464 |   |円 |                          214,536 |   |円 |             0|  5,270 |   |円 
 [10]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [11]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [12]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [13]|        2|   |          |   |   |   |                      |   |   |                                  |   |   |             0|        |   |   
 [14]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [15]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [16]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [17]|        3|   |          |   |   |   |                      |   |   |                                  |   |   |             0|        |   |   
 [18]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [19]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [20]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [21]|        4|   |          |   |   |   |                      |   |   |                                  |   |   |             0|        |   |   
 [22]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [23]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [24]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [25]|        5|   |          |   |   |   |                      |   |   |                                  |   |   |             0|        |   |   
 [26]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [27]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [28]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [29]|        6|   |          |   |   |   |                      |   |   |                                  |   |   |             0|        |   |   
 [30]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [31]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [32]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [33]|        7|   |          |   |   |   |                      |   |   |                                  |   |   |             0|        |   |   
 [34]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [35]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [36]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [37]|        8|   |          |   |   |   |                      |   |   |                                  |   |   |             0|        |   |   
 [38]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [39]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [40]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [41]|        9|   |          |   |   |   |                      |   |   |                                  |   |   |             0|        |   |   
 [42]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [43]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [44]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [45]|       10|   |          |   |   |   |                      |   |   |                                  |   |   |             0|        |   |   
 [46]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [47]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [48]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [49]|       11|   |          |   |   |   |                      |   |   |                                  |   |   |             0|        |   |   
 [50]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [51]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [52]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [53]|       12|   |          |   |   |   |                      |   |   |                                  |   |   |             0|        |   |   
 [54]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [55]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
 [56]|         |   |          |   |   |   |                      |   |   |                                  |   |   |              |        |   |   
この下に合計額が入ります。
(ひなた) 2019/03/19(火) 10:57

 >With Sheets(CStr(ws.Cells(4, c).Value)) → インデックスが有効範囲にありませんエラー '値を文字型に変更、4行目の社員番号の値
 インデックスエラーになるなら、それはシート名が存在しないってことです。
 セルの値が誤っている(空白があるとか)かシート名が誤っているので
 1)
 debug.print "[" & CStr(ws.Cells(4, c).Value) & "]"
 をWithの前に入れて、値を教えてください。

 2)
    Sub シート名取得()
        Dim ws As Worksheet
        For Each ws In Sheets
            Debug.Print ws.Name
        Next ws
    End Sub
 このコードを実行して、シート名一覧をこちらに出してもらえますか?

 あと
 >?ws.Cells(15, c).Address
 >とイミディエイトウィンドウに打ち込んで、希望のセル範囲になっているか確認しました?
 こちらはどうなりましたか?

(稲葉) 2019/03/19(火) 11:56


稲葉さん

お世話になっております。
すみません、4行目だと私が思っているところ、もう一度教えて欲しいのですが
Cells(4,c)
この部分、4はシートですか?

1)
debug.print "[" & CStr(ws.Cells(4, c).Value) & "]"With Sheets(CStr(ws.Cells(4, c).Value))
ということでしょうか?構文エラーになってしまったのですが

2)
COO
COO2
E-Pay
P-Pay
E-bonus
P-bonus
Pay-bill
Bonus-bill
1
2
3
7
8
5
徴収簿裏面
一覧
?1
?2
?3
?5
?7
?8

3)インデックスが有効範囲にありませんとエラーが出ますので、ステップインでも進むことができず、確認できませんでした。
(ひなた) 2019/03/19(火) 13:00


編集かぶったけどそのまま

またまた横からですけど、「(ひなた) 2019/03/19(火) 10:57」に提示されたレイアウトを拝見すると

 ●月を調べるには・・・E-Payシートの「D1」セルに【日付型】のデータがあるのでそこから【何月】か調べればよい

ということになりますね。
一方で、新しい情報として

 ●E-Payシートの4行目に社員番号があるが、必ずしも若い順に並んでる訳でない

というように読めますが、合ってますか?
また、転記の対象としたいのは、E-Payシートの

 15行目にあたる【課税分小計】と
 23行目(例示されていない)

の二つという理解でよいのでしょうか?
さらに、出力先のシート(セル)は、

 "F9:H10","F13:H14","F17:H18","F21:H22"...
 "J9:K10","J13:K14","J17:K18","J17:K18"...

のように、間に2行入る感じ(4行分ずれ)でそれぞれの塊が結合されているという理解で良いですか?

仮に、上のとおりならばですが、一例で

 (1)E-Payシートの「D1」から【何月】であるかを取得する

 (2)E-Payシートの4行目のうち【何列目】に対象の社員番号があるか調べる → 無い場合はユーザーに通知のうえ次の社員番号へ移行
 (3)ブック内に対象の社員番号シートがあるか調べる → 無い場合はエラーメッセージを表示して終了

 (4)E-Payシートの15行目、【何列目】の値を覚えておく
 (5)E-Payシートの23行目、【何列目】の値を覚えておく

 (6)社員番号シートの(5 + (4 * 【何月】))行目、F列のセルに(4)で覚えた値をコピペ転記する
 (7)社員番号シートの(5 + (4 * 【何月】))行目、J列のセルに(5)で覚えた値を転記する

 (8)(2)〜(7)を社員番号1〜9まで繰り返す

という処理を考えてみてはどうでしょうか?

P.S.
「(もこな2) 2019/03/18(月) 13:14」を読み直してみたら敬称が抜けてました。
稲葉さんごめんなさい。

(もこな2) 2019/03/19(火) 13:10


たびたびすみません。「(もこな2) 2019/03/19(火) 13:10」でもミスりました。

 誤 〜コピペ転記〜 
 正 〜コピペではなく値を転記〜

そして、「(もこな2) 2019/03/19(火) 13:10」の案をコード化するとこんな感じになるとおもいます。

    Sub さんぷる()
        Dim 何月 As Long
        Dim 何列目 As Variant
        Dim 社員番号 As Long
        Dim dstSH As Worksheet

        Dim 覚えておく値1, 覚えておく値2

        Stop '←ブレークポイントのかわり

        With Worksheets("E-Pay")
            何月 = Month(.Range("D1").Value)

            For 社員番号 = 1 To 9

                If 社員番号 = 4 Then 社員番号 = 社員番号 + 1 '★良い手が思いつかないのでとりあえず

                何列目 = Application.Match(社員番号, .Rows(4), 0)
                If IsError(何列目) Then
                    MsgBox "社員番号 " & 社員番号 & " が見つかりません" & vbCrLf & "次の社員番号に移行します"
                Else
                    On Error Resume Next
                    Set dstSH = Worksheets(CStr(社員番号))
                    On Error GoTo 0
                    If dstSH Is Nothing Then
                        MsgBox CStr(社員番号) & "シートがありません" & vbCrLf & "処理を中止します"
                        Exit Sub
                    End If

                    覚えておく値1 = .Cells(15, 何列目).Value
                    覚えておく値2 = .Cells(23, 何列目).Value

                    dstSH.Cells((5 + (4 * 何月)), "F").Value = 覚えておく値1
                    dstSH.Cells((5 + (4 * 何月)), "J").Value = 覚えておく値2

                    Set dstSH = Nothing
                End If
            Next 社員番号
        End With

    End Sub

(もこな2) 2019/03/19(火) 15:58


もこな2さん

ありがとうございます。
まず、質問にお答えしますと

●月を調べるには・・・E-Payシートの「D1」セルに【日付型】のデータがあるのでそこから【何月】か調べればよい→その通りです。

●E-Payシートの4行目に社員番号があるが、必ずしも若い順に並んでる訳でない
→そうですね、入社順ですが、そこら辺は私の判断で順番にできないことはないです。ただ4番は欠番です。

また、転記の対象としたいのは、E-Payシートの

 15行目にあたる【課税分小計】と
 23行目(例示されていない)
の二つという理解でよいのでしょうか? 
→[15]課税分小計
  [23]社会保険料控除額(誤って削除してしまいました)
  [24]差引控除後の金額
  [25]所得税  
です。        
出力先のシート(セル)は、 
 "F9:H10","F13:H14","F17:H18","F21:H22"...
 "J9:K10","J13:K14","J17:K18","J21:K22"...
 "M9:N10","M13:N14","M17:N18","M21:N22"...
 "Q9:R10","Q13:R14","Q17:R18","Q21:R22"...
となります。
(ひなた) 2019/03/19(火) 16:47

 1)は
 debug.print "[" & CStr(ws.Cells(4, c).Value) & "]" ’←E-Payシートの4行目変数c列の値を調べる
 With Sheets(CStr(ws.Cells(4, c).Value)) 
 このようにしてほしかったです。
 そうすれば、前後にスペースがあるとかないとかわかるので・・・

 2)は私のコードが失敗でした。
 こっちで再度お願いします。
    Sub シート名取得()
        Dim ws As Worksheet
        For Each ws In Sheets
            Debug.Print "[" & ws.Name & "]"
        Next ws
    End Sub

 3)
 提示してもらったデータでこちらは問題なくコピーできましたので、シート名が異なっている可能性が高いです。
 シートの有無をチェックするコードを追加したので、再度実行してみてください。
    Sub Copy2()
        Dim ws As Worksheet
        Dim m As Long
        Dim c As Long
        Dim msg As String
        Set ws = Sheets("E-Pay")
        m = Month(ws.Range("D1").Value) * 4 + 5 '1月×4行+5行、1月は9行目から
        For c = 5 To ws.Cells(4, Columns.Count).End(xlToLeft).Column Step 2 '社員番号の始まり5列目、4行目の最終列から左方向の入力済み終端セルを取得、1列飛ばし
            If Evaluate("=ISREF(" & CStr(ws.Cells(4, c).Value) & "!A1)") Then
                With Sheets(CStr(ws.Cells(4, c).Value)) ' → インデックスが有効範囲にありませんエラー '値を文字型に変更、4行目の社員番号の値
                    .Cells(m, "F").Value = ws.Cells(15, c).Value
                    .Cells(m, "J").Value = ws.Cells(23, c).Value
                End With
            Else
                msg = msg & vbCrLf & "社員番号:" & ws.Cells(4, c).Value
            End If
        Next c
        If msg <> "" Then
            MsgBox Mid$(msg, 2) & "のシートが見つかりませんでした"
        End If
    End Sub

(稲葉) 2019/03/19(火) 17:18


>出力先のシート(セル)は、
> "F9:H10","F13:H14","F17:H18","F21:H22"...
> "J9:K10","J13:K14","J17:K18","J21:K22"...
> "M9:N10","M13:N14","M17:N18","M21:N22"...
> "Q9:R10","Q13:R14","Q17:R18","Q21:R22"...
>となります。

じつは、出力先のセル番地より、どのように結合されているのかが確認したかったことですが、聞き方がまずかったです。
とりあえず提示の部分がそっくり(2行3列の塊で)結合されているとした場合です。

    Sub さんぷる()
        Dim 何月 As Long
        Dim 何列目 As Variant
        Dim 社員番号 As Long
        Dim dstSH As Worksheet

        Stop '←ブレークポイントのかわり

        With Worksheets("E-Pay")
            何月 = Month(.Range("D1").Value)

            For 社員番号 = 1 To 9

                If 社員番号 = 4 Then 社員番号 = 社員番号 + 1 '★良い手が思いつかないのでとりあえず

                何列目 = Application.Match(社員番号, .Rows(4), 0)

                If IsError(何列目) Then
                    MsgBox "社員番号 " & 社員番号 & " が見つかりません" & vbCrLf & "次の社員番号に移行します"
                Else
                    On Error Resume Next
                    Set dstSH = Worksheets(CStr(社員番号))
                    On Error GoTo 0
                    If dstSH Is Nothing Then
                        MsgBox CStr(社員番号) & "シートがありません" & vbCrLf & "処理を中止します"
                        Exit Sub
                    End If

                    dstSH.Cells((5 + (4 * 何月)), "F").Value = .Cells(15, 何列目).Value
                    dstSH.Cells((5 + (4 * 何月)), "J").Value = .Cells(23, 何列目).Value
                    dstSH.Cells((5 + (4 * 何月)), "M").Value = .Cells(24, 何列目).Value
                    dstSH.Cells((5 + (4 * 何月)), "Q").Value = .Cells(25, 何列目).Value

                    Set dstSH = Nothing
                End If

            Next 社員番号
        End With
    End Sub

(もこな2) 2019/03/19(火) 19:01


順番が前後して申し訳ありません、稲葉さんの方から先に返信させていただきます。

稲葉さん

1)失礼しました。With〜を改行したら動作しました。びっくりぽんです。

2)

[COO]
[COO2]
[E-Pay]
[P-Pay]
[E-bonus]
[P-bonus]
[Pay-bill]
[Bonus-bill]
[1]
[2]
[3]
[7]
[8]
[5]
[徴収簿裏面]
[一覧]
[?1]
[?2]
[?3]
[?5]
[?7]
[?8]

3)できました!昨日まで何故できなかったのか謎です・・・
(ひなた) 2019/03/20(水) 08:46


もこな2さん

ありがとうございます。
返信の順番前後して申し訳ありませんでした。
もこな2さんのコードサンプルでもバッチリできました!
InputBoxもMsgBoxも使ったことがなかったので、使い方も勉強になりました。
(ひなた) 2019/03/20(水) 08:50


 できたようで良かったです
 解決でよろしいですかね?
(稲葉) 2019/03/20(水) 09:00

稲葉さん

はい、あとは貼付け先の欄を自分で増やして解決できましたので。
長い間お付き合いいただきありがとうございました。
丁寧に教えていただき、大変勉強になりました。
(ひなた) 2019/03/20(水) 12:27


コメント返信:

[ 一覧(最新更新順) ]


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