[[20130612011339]]　『データー集め』（ちぃさん）　ページの最後に飛ぶ

『データー集め』（ちぃさん）

いつもお世話になります。
データー集めをしたいのですがマクロで便利に早くできればと思い質問にまいりました。
マクロどころか関数ですら理解できていない私ですが宜しくお願いします。

入力シートとして使っている
仮名:333.xlsm
仮名:Sheet1
仮セル番:B5,C5,E5,F5,H5,I5,C7,F7,I7,B15,C15,E15,F15,H15,I15
に入力した値を同じBook1の別シート
データを収集しようとしている
仮名:333.xlsm
仮名:Sheet2
仮セル番:B2,C2,D2,E2,F2,G2,H2,I2,J2,K2,L2,M2,N2,O2,P2
に転記したいです。
入力シートとして使っているシートは使い回しなので次回使う場合は入力した値を消去しまた値を入力します。
データを収集しようとしているシートは入力シートとして使っているシートの値を消去しても消えないでほしいです。

仮に6/11に入力シートとして使っているのセルB5,C5,E5,F5,H5,I5,C7,F7,I7,B15,C15,E15,F15,H15,I15に入力すればSheet2のB2,C2,D2,E2,F2,G2,H2,I2,J2,K2,L2,M2,N2,O2,P2に
6/11 ・・・・・・・・・・・
6/12に入力シートとして使っているのセルB5,C5,E5,F5,H5,I5,C7,F7,I7,B15,C15,E15,F15,H15,I15に入力すればSheet2のB3,C3,D3,E3,F3,G3,H3,I3,J3,K3,L3,M3,N3,O3,P3に
6/12・・・・・・・・・・・・
6/25に入力シートとして使っているのセルB5,C5,E5,F5,H5,I5,C7,F7,I7,B15,C15,E15,F15,H15,I15に入力すればSheet2のB4,C4,D4,E4,F4,G4,H4,I4,J4,K4,L4,M4,N4,O4,P4に
6/25・・・・・・・・・・・・
と最下行の次の行に貼り付けを繰り返したいです。

過去ログに私が望んでいる回答に近いものがありましたので試してみたのですが・・・[[20130526180206]]←コチラのものを解らないなりに真似して

Sub Sample()

    Dim shF As Worksheet
    Dim r1 As Range
    Dim r2 As Range
    Dim r3 As Range
    Dim r4 As Range
    Dim r5 As Range
    Dim r6 As Range
    Dim r7 As Range
    Dim r8 As Range
    Dim r9 As Range
    Dim r10 As Range
    Dim r11 As Range
    Dim r12 As Range
    Dim r13 As Range
    Dim r14 As Range
    Dim r15 As Range

    Set shF = Workbooks("333.xlsm").Sheets("Sheet1")

    With shF
        Set r1 = .Range("B5", .Range("B" & .Rows.Count).End(xlUp))
        Set r2 = .Range("C5", .Range("C" & .Rows.Count).End(xlUp))
        Set r3 = .Range("E5", .Range("E" & .Rows.Count).End(xlUp))
        Set r4 = .Range("F5", .Range("F" & .Rows.Count).End(xlUp))
        Set r5 = .Range("H5", .Range("H" & .Rows.Count).End(xlUp))
        Set r6 = .Range("I5", .Range("I" & .Rows.Count).End(xlUp))
        Set r7 = .Range("C7", .Range("C" & .Rows.Count).End(xlUp))
        Set r8 = .Range("F7", .Range("F" & .Rows.Count).End(xlUp))
        Set r9 = .Range("I7", .Range("I" & .Rows.Count).End(xlUp))
        Set r10 = .Range("B15", .Range("B" & .Rows.Count).End(xlUp))
        Set r11 = .Range("C15", .Range("C" & .Rows.Count).End(xlUp))
        Set r12 = .Range("E15", .Range("E" & .Rows.Count).End(xlUp))
        Set r13 = .Range("F15", .Range("F" & .Rows.Count).End(xlUp))
        Set r14 = .Range("H15", .Range("H" & .Rows.Count).End(xlUp))
        Set r15 = .Range("I15", .Range("I" & .Rows.Count).End(xlUp))
    End With

    With Workbooks("333.xlsm").Sheets("Sheet2")
        r1.Copy .Range("B" & .Rows.Count).End(xlUp).Offset(2)
        r2.Copy .Range("C" & .Rows.Count).End(xlUp).Offset(2)
        r3.Copy .Range("D" & .Rows.Count).End(xlUp).Offset(2)
        r4.Copy .Range("E" & .Rows.Count).End(xlUp).Offset(2)
        r5.Copy .Range("F" & .Rows.Count).End(xlUp).Offset(2)
        r6.Copy .Range("G" & .Rows.Count).End(xlUp).Offset(2)
        r7.Copy .Range("H" & .Rows.Count).End(xlUp).Offset(2)
        r8.Copy .Range("I" & .Rows.Count).End(xlUp).Offset(2)
        r9.Copy .Range("J" & .Rows.Count).End(xlUp).Offset(2)
        r10.Copy .Range("K" & .Rows.Count).End(xlUp).Offset(2)
        r11.Copy .Range("L" & .Rows.Count).End(xlUp).Offset(2)
        r12.Copy .Range("M" & .Rows.Count).End(xlUp).Offset(2)
        r13.Copy .Range("N" & .Rows.Count).End(xlUp).Offset(2)
        r14.Copy .Range("O" & .Rows.Count).End(xlUp).Offset(2)
        r15.Copy .Range("P" & .Rows.Count).End(xlUp).Offset(2)
    End With

 End Sub

と記述しましたが転記されたセルがSheet2のB3,C3,D3,E3,F3,G3,H3,I3,J3,K3,L3,M3,N3,O3,P3に転記、さらにプラスしC5,E5,G5,H6,I6,J6,H7,I7,J7,B8,C8,D8,E8,F8,G8,B9,C9,D9,E9,F9,G9,H11,I11,J11,B13,C13,D13,E13,F13,G13に転記されました。
どこを直せばいのか全くわかりません。
助けて頂きたいたいです。

最終はデータを収集しようとしているシートを選択した時に値を入力したシートの値と入力」した日付が転記できるマクロが希望です。
解りにくい説明で申し訳ないです。
説明内容で情報不足な部分がありましたら指摘ください。
どうぞ宜しくお願いします。

WindowsXP　Excel2003、Windows 7　Excel2010　で可能な環境が希望です。

 >さらにプラスし
 >C5,E5,G5,H6,I6,J6,H7,I7,J7,B8,C8,D8,E8,F8,G8,B9,C9,D9,E9,F9,G9,H11,I11,J11,B13,C13,D13,E13,F13,G13に転記されました。

 それは、そういうコードになっているから。
 入力シートのC列のコードをサンプルにとるなら

 >6/12に入力シートとして使っているのセルC5,C7,C15に入力すれば

 Set r2 = .Range("C5", .Range("C" & .Rows.Count).End(xlUp))

 　これは、C5から、そのときのC列のデータ最終セル、C15までを取得(C5:C15)

 r2.Copy .Range("C" & .Rows.Count).End(xlUp).Offset(2)

 　上記で取得した C5:C15 の 9セルを Sheet2 のC列のデータ最終行 +2 のところ
 　(前日のデータから【1行あけて】）に、『9セル』を転記。

 こうなっているよ。

 以下は C列の分のみを書いたもの。他の列も同様に。

 Sub Sample2()
    Dim shF As Worksheet
    Dim shT As Worksheet

    Set shF = Workbooks("333.xlsm").Sheets("Sheet1")
    Set shT = Workbooks("333.xlsm").Sheets("Sheet2")

    With shT
        .Range("C" & .Rows.Count).End(xlUp).Offset(1).Value = shF.Range("C5")
        'または
        shF.Range("C5").Copy .Range("C" & .Rows.Count).End(xlUp).Offset(1)
    End With

 End Sub

 なお、もし、ある日の入力でどこかの入力セルが空白だった場合、その次の日はその空白セルは未入力とみなすので
 他の列に書き込まれた行とは異なる行に書き込まれる。
 これは具合悪いのでは？
 xlUP で書き込み行を調べる際に、各行毎に調べるのではなく、絶対に値がある代表列で調べて
 各列、全て、その行に書き込んだらいいんじゃないかな？

 それと、このマクロブックが 333.xlsm なら　Workbooks("333.xlsm")　のかわりに ThisWorkbook のほうがいいかも。

 (ぶらっと)

 ↑でいった、転記先のどこかの列で転記行を決定することができるなら、仮にそれをＢ列だとすると。

 Sample3 がコピペ方式、Sampl4,Sample5 が　セル.Value = セル.Value 方式。
 (Sample5　は　転記実行コードを１行にしたもの）

 Sub Sample3()
    Dim shF As Worksheet
    Dim shT As Worksheet
    Dim z As Long

    Set shF = Workbooks("333.xlsm").Sheets("Sheet1")
    Set shT = Workbooks("333.xlsm").Sheets("Sheet2")

    With shT
        '転移シートデータ最終行をB列で判断
        z = .Range("B" & .Rows.Count).End(xlUp).Row + 1
        shF.Range("B5").Copy .Range("B" & z)
        shF.Range("C5").Copy .Range("C" & z)
        shF.Range("E5").Copy .Range("D" & z)
        shF.Range("F5").Copy .Range("E" & z)
        shF.Range("H5").Copy .Range("F" & z)
        shF.Range("I5").Copy .Range("G" & z)
        shF.Range("C7").Copy .Range("H" & z)
        shF.Range("F7").Copy .Range("I" & z)
        shF.Range("F7").Copy .Range("J" & z)
        shF.Range("B15").Copy .Range("K" & z)
        shF.Range("C15").Copy .Range("L" & z)
        shF.Range("E15").Copy .Range("M" & z)
        shF.Range("F15").Copy .Range("N" & z)
        shF.Range("H15").Copy .Range("O" & z)
        shF.Range("I15").Copy .Range("P" & z)
    End With

 End Sub

 Sub Sample4()
    Dim shF As Worksheet
    Dim shT As Worksheet
    Dim z As Long

    Set shF = Workbooks("333.xlsm").Sheets("Sheet1")
    Set shT = Workbooks("333.xlsm").Sheets("Sheet2")

    With shT
        '転移シートデータ最終行をB列で判断
        z = .Range("B" & .Rows.Count).End(xlUp).Row + 1
        .Range("B" & z).Value = shF.Range("B5").Value
        .Range("C" & z).Value = shF.Range("C5").Value
        .Range("D" & z).Value = shF.Range("E5").Value
        .Range("E" & z).Value = shF.Range("F5").Value
        .Range("F" & z).Value = shF.Range("H5").Value
        .Range("G" & z).Value = shF.Range("I5").Value
        .Range("H" & z).Value = shF.Range("C7").Value
        .Range("I" & z).Value = shF.Range("F7").Value
        .Range("J" & z).Value = shF.Range("F7").Value
        .Range("K" & z).Value = shF.Range("B15").Value
        .Range("L" & z).Value = shF.Range("C15").Value
        .Range("M" & z).Value = shF.Range("E15").Value
        .Range("N" & z).Value = shF.Range("F15").Value
        .Range("O" & z).Value = shF.Range("H15").Value
        .Range("P" & z).Value = shF.Range("I15").Value
    End With

 End Sub

 Sub Sample5()
    Dim shF As Worksheet
    Dim shT As Worksheet
    Dim z As Long

    Set shF = Workbooks("333.xlsm").Sheets("Sheet1")
    Set shT = Workbooks("333.xlsm").Sheets("Sheet2")

    With shT
        '転移シートデータ最終行をB列で判断
        z = .Range("B" & .Rows.Count).End(xlUp).Row + 1
        .Range("B" & z & ":P" & z).Value = Array( _
                shF.Range("B5").Value, _
                shF.Range("C5").Value, _
                shF.Range("E5").Value, _
                shF.Range("F5").Value, _
                shF.Range("H5").Value, _
                shF.Range("I5").Value, _
                shF.Range("C7").Value, _
                shF.Range("F7").Value, _
                shF.Range("F7").Value, _
                shF.Range("B15").Value, _
                shF.Range("C15").Value, _
                shF.Range("E15").Value, _
                shF.Range("F15").Value, _
                shF.Range("H15").Value, _
                shF.Range("I15").Value)
    End With

 End Sub

 (ぶらっと)

 (ぶらっと)サン　回答ありがとうございます。

毎回感謝しています。
コピペ方式よりSampl4,Sample5 のほうが私の好みでしたｗ
パターンを沢山ありがとうございます。
転記位置もＢ列でOKです。

あと、2点
1,この転記した列の先頭のＡ列に転記した日付を表示したいのですがかこうでしょうか？
2,今はボタンをクリックした時にマクロが実行されているものをSheet2を選択した時に転記できている状態にしたいです。
2,の所で解りにくい説明でしたら指摘ください。

どうぞ宜しくお願いします。

（ちぃさん）

 Sample5 をベースに日付セットと、Sheet2を選択したときに実行するパターン。

 Sheet2 のシートタブを右クリック、コードの表示を選んで出てくるところに

 Private Sub Worksheet_Activate()
    Dim shF As Worksheet
    Dim z As Long

    Set shF = Workbooks("333.xlsm").Sheets("Sheet1")

    '転移シートデータ最終行をB列で判断
    z = Range("B" & Rows.Count).End(xlUp).Row + 1
    Range("A" & z & ":P" & z).Value = Array( _
            Date, _
            shF.Range("B5").Value, _
            shF.Range("C5").Value, _
            shF.Range("E5").Value, _
            shF.Range("F5").Value, _
            shF.Range("H5").Value, _
            shF.Range("I5").Value, _
            shF.Range("C7").Value, _
            shF.Range("F7").Value, _
            shF.Range("F7").Value, _
            shF.Range("B15").Value, _
            shF.Range("C15").Value, _
            shF.Range("E15").Value, _
            shF.Range("F15").Value, _
            shF.Range("H15").Value, _
            shF.Range("I15").Value)
 End Sub

 (ぶらっと)

(ぶらっと)サン　回答ありがとうございます。

あ、すみません。
回答いただいた内容は完璧です。が、私の言葉足らずな部分がありました。

＞2,今はボタンをクリックした時にマクロが実行されているものをSheet2を選択した時に転記できている状態にしたいです。
この説明に誤りがありました。
本当に申し訳ないです。

値が一部でも更新せれていればSheet2を選択した時に転記できている状態に変更できますでしょうか？
私の言葉足らずのために二度手間のなり申し訳ありません。

何卒宜しくお願いいたします。

（ちぃさん）

すみません。

testで転記させる選択範囲40個まで増やしてみようですが選択範囲が24個で警告がでました。

「行継続文字()_を使いすぎています。」

 Private Sub Worksheet_Activate()
    Dim shF As Worksheet
    Dim z As Long

    Set shF = Workbooks("333.xlsm").Sheets("Sheet1")

    '転移シートデータ最終行をB列で判断
    z = Range("B" & Rows.Count).End(xlUp).Row + 1
    Range("A" & z & ":AN" & z).Value = Array( _
            Date, _
            shF.Range("B5").Value, _
            shF.Range("C5").Value, _
            shF.Range("E5").Value, _
            shF.Range("F5").Value, _
            shF.Range("H5").Value, _
            shF.Range("I5").Value, _
            shF.Range("C7").Value, _
            shF.Range("F7").Value, _
            shF.Range("F7").Value, _
            shF.Range("B15").Value, _
            shF.Range("C15").Value, _
            shF.Range("E15").Value, _
            shF.Range("B10").Value, _
            shF.Range("C10").Value, _
            shF.Range("D10").Value, _
            shF.Range("E10").Value, _
            shF.Range("F10").Value, _
            shF.Range("G10").Value, _
            shF.Range("H10").Value, _
            shF.Range("I10").Value, _
            shF.Range("B11").Value, _
            shF.Range("C11").Value, _
            shF.Range("I15").Value)
 End Sub

Range("A" & z & ":P" & z).Value = Array( _
↑この部分のP1はANに変えたのですが・・・・
Range("A" & z & ":AN" & z).Value = Array( _

また私が全然意味不明な事をしているのでしょうか？
何度も申し訳ないです。
助けて頂けないでしょうか？
宜しくお願いいたします。

（ちぃさん）

 まず、１つ、ごめん　を。
 アップしたコード、転記元セルの F7 が重複してたね。　２つめの F7 は I7 だったね。
 さておき、「行継続文字()_を使いすぎています。」これは【文字通り】継続文字( _ ) が多すぎるということで
 24個が許容範囲の上限みたいね。

 もともと、継続文字は、１行で長いコードを書くと、ＶＢＡ画面でみづらくなるので　適宜、 半角スペースと　_　で区切って、次の行にコードの残りを記述するもの。
 アップしたコードでは、セル１つずつで区切ったのでセル数分の _ が必要になっている。
 これを、たとえばセル３つ分ずつで１行にすれば、解決することにはなる。

 ただ、この書き方、確かに、転記実行は１回になるので効率的といえば効率的だけど、コードを追加したり変更したりする場合に
 かえって、やりにくくなるかもね。

 なので、少し、このコードを変えてみる。

 あわせて、現在の仕掛けは Sheet2 が表示されると無条件に１行追加される。
 Sheet1　の変更後、最初に Sheet2が表示されたら行追加するけど、 行追加されたら、次に　Sheet1 が変更のない限り
 Sheet2 を開いても、行追加されないコードにしよう。

 後程アップするのでしばしお待ち乞う。

 (ぶらっと)

(ぶらっと)サン　回答ありがとございます。

＞Sheet2 を開いても、行追加されないコードにしよう。
了解です。
本当に何度もすみません。
宜しくお願いいたします。

（ちぃさん）

 それでは、現在の Sheet2 のシートモジュールのコードをすべて消したうえで、
 ThisWorkbookモジュールに以下を貼り付け。
 （ＶＢＥ画面の左上のプロジェクトエクスプローラの中の ThisWorkbook をダブルクリックするとでてくるところ）

 Option Explicit

 Dim flag As Boolean
 Const copyR As String = "B5,C5,E5,F5,H5,I5,C7,F7,I7,B15,C15,E15,B10,C10,D10,E10,F10,G10,H10,I10,B11,C11,I15"

 Private Sub Workbook_SheetActivate(ByVal Sh As Object)

    If Not Sh Is Sheets("Sheet2") Or Not flag Then Exit Sub

    CopyLine

 End Sub

 Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Not Sh Is Sheets("Sheet1") Then Exit Sub
    If Not Intersect(Target, Sh.Range(copyR)) Is Nothing Then flag = True
 End Sub

 Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    If flag Then CopyLine
 End Sub

 Private Sub CopyLine()
    Dim shF As Worksheet
    Dim z As Long
    Dim x As Long
    Dim v() As Variant
    Dim c As Range
    Dim k As Long
    Dim shT As Worksheet

    Set shF = Sheets("Sheet1")
    Set shT = Sheets("Sheet2")

    '転移シートデータ最終行をB列で判断
    z = shT.Range("B" & shT.Rows.Count).End(xlUp).Row + 1
    With shF.Range(copyR)
        x = .Count + 1 'コピーセル数+1
        ReDim v(1 To x)
        v(1) = Date
        k = 1
        For Each c In .Cells
            k = k + 1
            v(k) = c.Value
        Next

        shT.Range("A" & z).Resize(, x).Value = v
        flag = False
    End With
 End Sub

 (ぶらっと)

(ぶらっと)サン　回答ありがとうございます。

求めていたものそのままです。
感謝感謝です。
試しにtestで選択範囲を50個
Const copyR As String = "B5,C5,E5,F5,H5,I5,C7,F7,I7,B10,C10,D10,E10,F10,G10,H10,I10,B11,C11,D11,E11,F11,G11,H11,I11,B15,C15,E15,F15,H15,I15,B18,C18,E18,F18,H18,I18,B20,C20,E20,F20,H20,I20,B22,C22,E22,F22,H22,I22,D23"
でも問題なく動きました。
さすがに50個も選択することはないのですがw

もし嫌でなければ勉強したいのであと少しお付き合いいただけないでしょか。
本当に勝手ながらすみません。続けます。
今、必要ではないのですがもし違うBookに転記ならば
＞If Not Sh Is Sheets("Sheet2") Or Not flag Then Exit Sub
この部分を
If Not Sh Is Workbooks("他のBook.xlsx").Worksheets("Sheet1") Or Not flag Then Exit Sub
と
＞Set shT = Sheets("Sheet2")
この部分を
Set shT = Workbooks("他のBook.xlsx").Worksheets("Sheet1")
かなと思ったのですが...
違うんですね。
もしかして他のBookに記録を残す場合はマクロコードが全然変わってしまうのですか？
もし迷惑でなければ教えてほしいです。
長々と同じことばかりで本当にすみません。

（ちぃさん）

あ、気づきました。
連続投稿すみません。
ThisWorkbookに記述しているからダメですよね。
申し訳ないです。
変な質問をしてしまいました。

（ちぃさん）

 自身で気づかれたこと祝着。

 ところで、エクセル区画に、このマクロブック（333.xlsm) と、別のブックが開かれていて
 その別のブックのシートに書き込みするということも、お望みならできるよ。

 (ぶらっと)

(ぶらっと)サン　回答ありがとうございます。

本当に恥ずかしい質問をすみません。
＞ところで、エクセル区画に、このマクロブック（333.xlsm) と、別のブックが開かれていて
＞その別のブックのシートに書き込みするということも、お望みならできるよ。

勉強させてください。
宜しくお願いいたします。

（ちぃさん）

 急いで書いたので、どこかに抜けがあるかもしれないけど。
 かつ、333.xlsm を開く前に　他のBook.xlsx を開いておかなければいけないという暫定版だけど。

 Thisworkbookモジュールを総入れ替え。いったん、保存して、また開いてみてくれるかな。

 Option Explicit

 Dim WithEvents xlapp As Application
 Dim flag As Boolean
 Dim wbOT As Workbook
 Const copyR As String = "B5,C5,E5,F5,H5,I5,C7,F7,I7,B15,C15,E15,B10,C10,D10,E10,F10,G10,H10,I10,B11,C11,I15"

 Private Sub Workbook_Open()
    Set xlapp = Application
    Set wbOT = Workbooks("他のBook.xlsx")
 End Sub

 Private Sub xlapp_WorkbookActivate(ByVal Wb As Workbook)
    If Wb Is wbOT And flag Then CopyLine
 End Sub

 Private Sub xlapp_SheetActivate(ByVal Sh As Object)
    If Not Sh Is wbOT.Sheets("Sheet1") Or Not flag Then Exit Sub
    CopyLine
 End Sub

 Private Sub xlapp_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Not Sh Is ThisWorkbook.Sheets("Sheet1") Then Exit Sub
    If Not Intersect(Target, Sh.Range(copyR)) Is Nothing Then flag = True
 End Sub

 Private Sub xlapp_WorkbookBeforeSave(ByVal Wb As Workbook, ByVal SaveAsUI As Boolean, Cancel As Boolean)
    If Not Wb Is wbOT Then Exit Sub
    If flag Then CopyLine
 End Sub

 Private Sub CopyLine()
    Dim shF As Worksheet
    Dim z As Long
    Dim x As Long
    Dim v() As Variant
    Dim c As Range
    Dim k As Long
    Dim shT As Worksheet

    Set shF = ThisWorkbook.Sheets("Sheet1")
    Set shT = wbOT.Sheets("Sheet1")

    '転移シートデータ最終行をB列で判断
    z = shT.Range("B" & shT.Rows.Count).End(xlUp).Row + 1
    With shF.Range(copyR)
        x = .Count + 1 'コピーセル数+1
        ReDim v(1 To x)
        v(1) = Date
        k = 1
        For Each c In .Cells
            k = k + 1
            v(k) = c.Value
        Next

        shT.Range("A" & z).Resize(, x).Value = v
        flag = False
    End With
 End Sub

 (ぶらっと)

(ぶらっと)サン　回答ありがとうございます。

転記できました。
でも警告？のようなものがでましたが.....。

「プライバシーに関する注意：このドキュメントには、マクロ、ActiveXコントロール、XML拡張子パックの情報、またはwebコンポーネントが含まれています。これらにはドキュメント検査機能で除去することのできない個人情報が含まれる場合があります。」
とでましたが
「はい」
をクリックで転記された値は保存されました。

でも一旦全てファイルを閉じ　他のBook.xlsx を開いた状態で　333.xlsm を開き試した結果問題なくマクロは動きました。
ThisWorkbookに記述していても他のBookにとばせるんですね。
ビックリしました。

（ちぃさん）
　　　　　　　　　　　　　　　　

(ぶらっと)サン
沢山の回答ありがとうございました。
十分すぎる内容でした。
毎度ですが私の我儘で最終は当初の質問内容から毎回ズレた質問になりすみません。
でもこんな私の我儘に付き合って頂き凄く感謝しております。
また解らない事などできましたら質問にまいりますのでその際はまたお世話になりたいです。
本当にありがとございました。

（ちぃさん）

本日、ご教示いただいたマクロを会社で使わせていただきまして問題なく動いたのですが追加が必要になりました。
完璧な解答だったのですが申し訳ないです。
追加というのは入力するシートの追加です。

仮名:333.xlsm
仮名:Sheet1　仮セル番:B5,C5,E5,F5,H5,I5,C7,F7,I7,B15,C15,E15,F15,H15,I15
仮名:Sheet2　仮セル番:B10,D10,F10,B11,D11,F11,H11
仮名:Sheet3　仮セル番:B18,C20,E18,F20,H18,I20
の入力データーを
仮名:他のBook.xlsx
仮名:Sheet1　
に全て転記です。
マクロの動かしかたは今のままが一番の好みです。
できますでしょうか？

今一度お助けください。
何卒宜しくお願いいたします。

（ちぃさん）

 前にコメントした気になっていた点も調整。マクロブックを先に開いても、別ブックを先に開いても大丈夫なようにした（つもり）
 また、どのブックを先に閉じても大丈夫（のはず）
 とだし（当然）マクロブック側でデータ変更してから、別ブックのSheet1を表示せずにマクロブックを閉じると、別ブックへの転記は行われない。

 マクロブック側の各シートに入れ終わった後、別ブックのSheet1を表示した時点で一括転記。

 ThisWorkbookモジュールを総入れ替え。

 Option Explicit

 Dim WithEvents xlapp As Application
 Dim flag As Boolean
 Dim wbOT As Workbook

 Const nameOT As String = "他のBook.xlsx"
 Const nameShTo As String = "Sheet1"

 Const copyR1 As String = "B5,C5,E5,F5,H5,I5,C7,F7,I7,B15,C15,E15,F15,H15,I15"
 Const copyR2 As String = "B10,D10,F10,B11,D11,F11,H11"
 Const copyR3 As String = "B18,C20,E18,F20,H18,I20"
 Const nameShFrom1 As String = "Sheet1"
 Const nameShFrom2 As String = "Sheet2"
 Const nameShFrom3 As String = "Sheet3"

 Private Sub Workbook_Open()
    Set xlapp = Application
    On Error Resume Next            'まだ開かれていなかった場合の対応
    Set wbOT = Workbooks(nameOT)
    On Error GoTo 0
 End Sub

 Private Sub xlapp_WorkbookOpen(ByVal Wb As Workbook)
    If Wb.Name = nameOT Then
        Set wbOT = Wb
        If wbOT.ActiveSheet.Name = nameShTo Then
            If flag Then CopyLine
        End If
    End If
 End Sub

 Private Sub xlapp_WorkbookActivate(ByVal Wb As Workbook)
    If Wb.Name = nameOT Then
        If Wb.ActiveSheet.Name = nameShTo Then
            If flag Then CopyLine
        End If
    End If
 End Sub

 Private Sub xlapp_SheetActivate(ByVal Sh As Object)
    If Sh.Parent.Name = nameOT Then
        If Sh.Name = nameShTo Then
            If flag Then CopyLine
        End If
    End If
 End Sub

 Private Sub xlapp_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Sh.Parent Is ThisWorkbook Then
        Select Case Sh.Name
            Case nameShFrom1
                If Not Intersect(Target, Sh.Range(copyR1)) Is Nothing Then flag = True
            Case nameShFrom2
                If Not Intersect(Target, Sh.Range(copyR2)) Is Nothing Then flag = True
            Case nameShFrom3
                If Not Intersect(Target, Sh.Range(copyR3)) Is Nothing Then flag = True
        End Select
    End If
 End Sub

 Private Sub CopyLine()
    Dim nameF As String
    Dim copyR As String

    Dim shF As Worksheet
    Dim z As Long
    Dim x As Long
    Dim y As Long
    Dim v() As Variant
    Dim c As Range
    Dim k As Long
    Dim shT As Worksheet

    Set shT = wbOT.Sheets(nameShTo)

    '転移シートデータ最終行をB列で判断
    z = shT.Range("B" & shT.Rows.Count).End(xlUp).Row + 1
    x = Range(copyR1).Count + Range(copyR2).Count + Range(copyR2).Count + 1 'コピーセル数+1
    ReDim v(1 To x)
    v(1) = Date
    k = 1
    For y = 1 To 3  '3領域
        nameF = VBA.Array(nameShFrom1, nameShFrom2, nameShFrom3)(y - 1)
        copyR = VBA.Array(copyR1, copyR2, copyR3)(y - 1)
        With Sheets(nameF).Range(copyR)
            For Each c In .Cells
                k = k + 1
                v(k) = c.Value
            Next
        End With
    Next

    shT.Range("A" & z).Resize(, x).Value = v
    flag = False

 End Sub

 (ぶらっと)

(ぶらっと)サン　解答ありがとうございます。

何度も新しくコードを組んでいただきまして助かります。
今回、ご教示いただきましたコードですが、私の説明が十分でなかった気がします。
Sheet1、Sheet2、Sheet3の転記は出来ていましたが転記された　他のBook.xlsx　Sheet1の転記位置の調整はできますでしょうか？

現在、他のBook.xlsx　Sheet1　に転記された状態は

     A     B        C       D      E       F       G       H       I       J    
1　日時　Sheet1　Sheet1　Sheet1　Sheet2　Sheet2　Sheet2　Sheet3　Sheet3  Sheet3　
2
3
.
.
.
この転記順を

     A     B        C       D      E           
1　日時　Sheet1　Sheet1　Sheet1　　　　　  　
2　日時　Sheet2
3　日時　Sheet3
.
.
.
このような転記順にできますでしょうか？

Sheet1の値が更新されていたら他のBook.xlsx　Sheet1を開いた際に最下行へ転記
もしSheet2もSheet3も値が更新されていれば最下行へ転記させたいのです。
転記される際は必ずA列から順に転記させたいのです。

非常に解りにくい説明で申し訳ないです。
説明が不十分でしたら指摘ください。

宜しくお願いいたします。

（ちぃさん）

連続投稿すみません。

追加説明です。
＞マクロブック側の各シートに入れ終わった後
値を入力するシートは複数あるのですが別物扱いになります。
仮名:Sheet1=試作シート
仮名:Sheet2=○社向けシート
仮名:Sheet3=社内向けシート　

何度も解りにくい説明を申し訳ないです。
どうぞ宜しくお願いいたします。

（ちぃさん）

 総入れ替えで試してみて。
 まだ勘違いがあるかもね。（Workbook_Open を変更しているので、マクロ変更後、一度、閉じてから、また開いて試してね）

 Option Explicit

 Dim WithEvents xlapp As Application
 Dim flag() As String
 Dim wbOT As Workbook

 Const nameOT As String = "他のBook.xlsx"
 Const nameShTo As String = "Sheet1"

 Const copyR1 As String = "B5,C5,E5,F5,H5,I5,C7,F7,I7,B15,C15,E15,F15,H15,I15"
 Const copyR2 As String = "B10,D10,F10,B11,D11,F11,H11"
 Const copyR3 As String = "B18,C20,E18,F20,H18,I20"
 Const nameShFrom1 As String = "Sheet1"
 Const nameShFrom2 As String = "Sheet2"
 Const nameShFrom3 As String = "Sheet3"

 Private Sub Workbook_Open()
    Set xlapp = Application
    On Error Resume Next            'まだ開かれていなかった場合の対応
    Set wbOT = Workbooks(nameOT)
    On Error GoTo 0
    ReDim flag(1 To 3)
 End Sub

 Private Sub xlapp_WorkbookOpen(ByVal Wb As Workbook)
    If Wb.Name = nameOT Then
        Set wbOT = Wb
        If wbOT.ActiveSheet.Name = nameShTo Then
            If Len(Join(flag, "")) Then CopyLine
        End If
    End If
 End Sub

 Private Sub xlapp_WorkbookActivate(ByVal Wb As Workbook)
    If Wb.Name = nameOT Then
        If Wb.ActiveSheet.Name = nameShTo Then
            If Len(Join(flag, "")) Then CopyLine
        End If
    End If
 End Sub

 Private Sub xlapp_SheetActivate(ByVal Sh As Object)
    If Sh.Parent.Name = nameOT Then
        If Sh.Name = nameShTo Then
            If Len(Join(flag, "")) Then CopyLine
        End If
    End If
 End Sub

 Private Sub xlapp_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Sh.Parent Is ThisWorkbook Then
        Select Case Sh.Name
            Case nameShFrom1
                If Not Intersect(Target, Sh.Range(copyR1)) Is Nothing Then flag(1) = "X"
            Case nameShFrom2
                If Not Intersect(Target, Sh.Range(copyR2)) Is Nothing Then flag(2) = "X"
            Case nameShFrom3
                If Not Intersect(Target, Sh.Range(copyR3)) Is Nothing Then flag(3) = "X"
        End Select
    End If
 End Sub

 Private Sub CopyLine()
    Dim nameF As String
    Dim copyR As String

    Dim shF As Worksheet
    Dim z As Long
    Dim x As Long
    Dim y As Long
    Dim v() As Variant
    Dim c As Range
    Dim k As Long
    Dim shT As Worksheet

    Set shT = wbOT.Sheets(nameShTo)

    For y = 1 To UBound(flag)
        If Len(flag(y)) Then
            '転移シートデータ最終行をA列で判断
            z = shT.Range("A" & shT.Rows.Count).End(xlUp).Row + 1
            nameF = VBA.Array(nameShFrom1, nameShFrom2, nameShFrom3)(y - 1)
            copyR = VBA.Array(copyR1, copyR2, copyR3)(y - 1)

            With Sheets(nameF).Range(copyR)

                x = Range(copyR).Count + 1              'コピーセル数+1
                ReDim v(1 To x)
                v(1) = Date
                k = 1

                For Each c In .Cells
                    k = k + 1
                    v(k) = c.Value
                Next

                shT.Range("A" & z).Resize(, x).Value = v

            End With
        End If
    Next

    ReDim flag(1 To UBound(flag))

 End Sub

 (ぶらっと)

 (ぶらっと)サン　回答ありがとうございます。
＞まだ勘違いがあるかもね。
とんでもないです。
私に原因があります。
私の説明不足と我儘のためにいつまでも同じ内容で手間を取らせて申し訳ないです。

新たに組んで頂きましたマクロ完璧でした。
今後、シートが増えたとして試しに選択のシートを10シート増やして試してみましたが問題ないです。
これ以上は求めることは今は思いつかないぐらい完璧な出来上がりでした。

長々とありがとうございました。
これで仕事も短縮できますし頭の中のモヤモヤも無くなりスッキリしました。
マクロの便利さを知りコチラで (ぶらっと)サン　によくお世話になりぱなしで本当になんとお礼を言っていいのか解らないぐらい感謝しております。

毎回質問内容を　(ぶらっと)サン　に解決していただいたのちにコード内容の説明や私の勘違いなどの指摘内容など何度も読み直してはいるのですが、その時は理解できているつもりでもやはり理解できていない。
マクロって超便利ですがコードを組むのは超難しいです。
でも少しづつは理解しているかもです。
今後も解らない事などありましたら質問にきたいのでその際はまた宜しくお願いいたします。

ありがとうございました。

コメント返信：

[ 一覧(最新更新順) ]

[[20130612011339]] 『データー集め』（ちぃさん） ページの最後に飛ぶ

[[20130612011339]]　『データー集め』（ちぃさん）　ページの最後に飛ぶ