[[20150404140303]]　『一行を区切って数列にコピー』（さち）　ページの最後に飛ぶ

『一行を区切って数列にコピー』（さち）

お世話になります。
先日こちらで質問した時にいただいたアドバイスを元に、
別のものを作っていますが、途中から動かなくなってしまいました。
またお力を貸してください。

選択した一行のうち、数分割してコピーしたいのですが、
その指示がうまくできません。

Sheet1
Ａ　Ｂ　Ｃ　Ｄ　Ｅ　Ｆ　Ｇ　Ｈ　Ｉ　Ｊ　Ｋ　Ｌ　М　Ｎ　Ｏ　Ｐ・・・
あ　い　う　　　　か　き　く　　こ　さ　し　　　せ　そ　た・・・

sheet2
Ａ　Ｂ　Ｃ
あ　さ　な
い　し　に
う　　
　　せ　ね
　　そ　の
か　た　は
き　ち　・
く　・　・
・　・　・　
・　・　・
という感じに、長い一行を区切って別シートの列にコピーできるようにしたいです。
途中には空白セルもあります。

Private Sub コピー_Click()

Rows(ActiveCell.Row).Copy
Worksheets("sheet2").Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

End Sub

で、カーソルを置いた行を、一行まるごと列にコピーできましたが、
セル番号等を入れると動きません。
行を区切って列にコピーする指示の書き方を教えてください。
よろしくお願いいたします。

＜使用 Excel：Excel2013、使用 OS：Windows8 ＞

 二つ確認したいのですけれど、
 ・区切るのは固定サイズなのでしょうか。
 ・動かないというコードは提示できますか？
（Mook） 2015/04/04(土) 14:46

区切るのは、シート1　A(通し番号),BｰD,E-N,O-X,Y-AH,AI-AL
　　　　　　　　シート2　A2,A3:A5,B2:B11,C2:C11,D2:D11,E2:E5　にコピーする
　
動かないコード
Rows(ActiveCell.Row,"A").resize(11).Copy
Worksheets("sheet2").Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,_
SkipBlanks:=False, Transpose:=True

Rows(ActiveCell.Row).Copyにあたる部分がどう書いても動かせません...

WS1に頭書き　
→WS2にコピー＋修正、加筆
→WS1の同じ管理番号の行に追加でコピーしてリスト完成→上書き保存
→WS1リストからWS2フォームへ呼び出し、修正、加筆→上書き保存
というループを作りたいのです。

シート２からシート１へコピーするマクロが以下です。
こちらが先にできました。
（シート１でアクティブにした行についての作業なので、
現在はシート１に保存ボタンを置いてあります）
Private Sub 保存_Click()

 Dim WS2 As Worksheet
 Dim WS1 As Worksheet
 Set WS2 = Worksheets("sheet2")
 Set WS1 = Worksheets("sheet1")

  With ActiveCell
  WS1.Range("A1").Value = WS4.Cells(.Row, "A").Value

  Worksheets("sheet2").Range("A2:A5").Copy
  WS1.Cells(.Row, "A").PasteSpecial Paste:=xlPasteValues, Transpose:=True
  Worksheets("sheet2").Range("B2:B11").Copy
  WS1.Cells(.Row, "E").PasteSpecial Paste:=xlPasteValues, Transpose:=True
  Worksheets("sheet2").Range("C2:C11").Copy
  WS1.Cells(.Row, "O").PasteSpecial Paste:=xlPasteValues, Transpose:=True
  Worksheets("sheet2").Range("D2:D11").Copy
  WS1.Cells(.Row, "Y").PasteSpecial Paste:=xlPasteValues, Transpose:=True
  Worksheets("sheet2").Range("E2:E5").Copy
  WS1.Cells(.Row, "AI").PasteSpecial Paste:=xlPasteValues, Transpose:=True

WS2.Range("A2:A5,B2:B11,C2:C11,D2:D11,E2:E5").ClearContents

End With
End Sub

さらに追加したいこと
WS1からマクロを走らせたらWS2を開く
WS2からWS1のコマンドボタンを押して保存
シートを移動する際にページ先頭あたりにセルを戻す

保存の際、WS1に戻って保存しているため、どこかちがうセルを触ってしまうと
データが消されてしまったりします。
WS1のA列（管理番号）がWS2のA2セルと同じだった場合のみ上書き保存
とした方が良いかも？と思っています。

日々改造奮闘中ですが、時間ばかりかかって進みません。
どうかよろしくお願いします！
（さち） 2015/04/04(土) 17:09

 要件もコードも読んでいませんが

 >Rows(ActiveCell.Row).Copyにあたる部分がどう書いても動かせません...

 コードとしては

 Rows(ActiveCell.Row,"A").resize(11).Copy

 ここのことですか？

 どんな領域をコピーしたいのかわからないのですが、Rows(ActiveCell.Row,"A")　こんな領域指定はありません。

 Cells(ActiveCell.Row,"A") か Rows(Activecell.Row) です。どちらが目的の領域かわかりませんが。

 なお、後者なら　ActiveCell.EntireRow という書き方もできます。

（β） 2015/04/04(土) 17:34

 >WS1に頭書き　 
 >→WS2にコピー＋修正、加筆 
 >→WS1の同じ管理番号の行に追加でコピーしてリスト完成→上書き保存 
 >→WS1リストからWS2フォームへ呼び出し、修正、加筆→上書き保存 
 >というループを作りたいのです。

 >さらに追加したいこと 
 >WS1からマクロを走らせたらWS2を開く 
 >WS2からWS1のコマンドボタンを押して保存 
 >シートを移動する際にページ先頭あたりにセルを戻す

 一生懸命、やりたいことを理解しようとして繰り返し読んでいるのですが、わかりません。

 同じ管理番号の行って？　あらかじめ、Sheet2 には、何か書かれていて、そこのしかるべきところに
 Sheet1から転記？

 Sheet1 は１行目だけ？それとも何行もあり？

 「頭書き」という意味も？？？

 「WS2からWS1のコマンドボタンを押して保存」？？

 Sheet2 を表示している状態で Sheet1 のコマンドボタンを押す？

 このSheet1のコマンドボタンには、どんなマクロが登録されているのかな？

 Private Sub 保存_Click()  このコードは動いている？動いていない？
 ここで、いきなり登場する WS4 って何？？

 等々、わからないところだらけですが。

 いずれにしても、最初に提示のあった、Sheet1の1行目を Sheet2の複数の列に分割して転記するのは
 そちらのコードを正しくすればできるでしょうし、あるいは以下のようなコードでも。

 Sub Test()

    Dim sh1 As Worksheet
    Dim sh2 As Worksheet

    Set sh1 = Sheets("Sheet1")
    Set sh2 = Sheets("Sheet2")

    sh2.Range("A2").Value = sh1.Range("A1").Value
    sh2.Range("A3:A5").Value = WorksheetFunction.Transpose(sh1.Range("B1:D1"))
    sh2.Range("B2:B11").Value = WorksheetFunction.Transpose(sh1.Range("E1:N1"))
    sh2.Range("C2:C11").Value = WorksheetFunction.Transpose(sh1.Range("O1:X1"))
    sh2.Range("D2:D11").Value = WorksheetFunction.Transpose(sh1.Range("Y1:AH1"))
    sh2.Range("E2:E5").Value = WorksheetFunction.Transpose(sh1.Range("AI1:AL1"))

 End Sub

（β） 2015/04/04(土) 18:02

 >選択した一行のうち、数分割してコピーしたいのですが

 ここを見過ごしていました。
 ↑のコードはボツにして以下。
 （でも、きっと Sheet2側は固定領域ではなく、何かしら検索してその対象の領域に転記するんだろうね。ほんとは）

 Sub Test2()

    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim myrow As Range

    Set sh1 = Sheets("Sheet1")
    Set sh2 = Sheets("Sheet2")

    sh1.Activate
    Set myrow = ActiveCell.EntireRow

    sh2.Range("A2").Value = myrow.Range("A1").Value
    sh2.Range("A3:A5").Value = WorksheetFunction.Transpose(myrow.Range("B1:D1"))
    sh2.Range("B2:B11").Value = WorksheetFunction.Transpose(myrow.Range("E1:N1"))
    sh2.Range("C2:C11").Value = WorksheetFunction.Transpose(myrow.Range("O1:X1"))
    sh2.Range("D2:D11").Value = WorksheetFunction.Transpose(myrow.Range("Y1:AH1"))
    sh2.Range("E2:E5").Value = WorksheetFunction.Transpose(myrow.Range("AI1:AL1"))

    sh2.Activate

 End Sub

（β） 2015/04/04(土) 18:10

 もしかして

 １．Sheet1でどこかの行を選択

 ２．Sheet2の「固定」の領域に転記

 ３．Sheet2側で加筆修正

 ４．加筆修正が終わったら、Sheet1 の該当の行に書き戻し

 こんなことをしたかったのかな？

（β） 2015/04/04(土) 18:15

 もし、↑の勝手な想像通りだとすれば。

 Sub Copy1To2() 'Sheet1 側のコマンドボタンに登録
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim myrow As Range

    Set sh1 = Sheets("Sheet1")
    Set sh2 = Sheets("Sheet2")

    sh1.Activate
    Set myrow = ActiveCell.EntireRow

    sh2.Range("A2").Value = myrow.Range("A1").Value
    sh2.Range("A3:A5").Value = WorksheetFunction.Transpose(myrow.Range("B1:D1"))
    sh2.Range("B2:B11").Value = WorksheetFunction.Transpose(myrow.Range("E1:N1"))
    sh2.Range("C2:C11").Value = WorksheetFunction.Transpose(myrow.Range("O1:X1"))
    sh2.Range("D2:D11").Value = WorksheetFunction.Transpose(myrow.Range("Y1:AH1"))
    sh2.Range("E2:E5").Value = WorksheetFunction.Transpose(myrow.Range("AI1:AL1"))

    Application.Goto sh2.Range("A1")

 End Sub

 Sub Back2To1() 'Sheet2 側のコマンドボタンに登録
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim c As Range

    Set sh1 = Sheets("Sheet1")
    Set sh2 = Sheets("Sheet2")
    Set c = sh1.Range("A1", sh1.Range("A" & Rows.Count).End(xlUp)).Find(What:=sh2.Range("A2").Value, LookAt:=xlWhole)
    If c Is Nothing Then
        MsgBox sh1.Name & " に " & sh2.Range("A2").Value & " が見つかりませんよ"
        Exit Sub
    End If

    With c.EntireRow

        .Range("A1").Value = sh2.Range("A2").Value
        .Range("B1:D1").Value = WorksheetFunction.Transpose(sh2.Range("A3:A5"))
        .Range("E1:N1").Value = WorksheetFunction.Transpose(sh2.Range("B2:B11"))
        .Range("O1:X1").Value = WorksheetFunction.Transpose(sh2.Range("C2:C11"))
        .Range("Y1:AH1").Value = WorksheetFunction.Transpose(sh2.Range("D2:D11"))
        .Range("AI1:AL1").Value = WorksheetFunction.Transpose(sh2.Range("E2:E5"))

    End With

    Application.Goto c

 End Sub

 19:10 追記　保存はいれていません。どういうタイミングで保存が必要かを決めてもらえれば
 　　　　　　いかようにでも対応します。

（β） 2015/04/04(土) 18:30

すごい...感動しました!!
こんなにさくさく動くなんて！
ありがとうございました。
言われたものを作るのに、調べてあれこれやってもできず、
そのうちに何をやっているんだか分からなくなりました。

シート１から２へ、２から１へ、移動する時にそれぞれのボタンで保存したいです。

シート１　Ａ列には通し番号がついているので、
シート２　Ａ２セルにも出したいです。

シート１、２とも一部ロックをかけてシート保護したいと思います。
ロックの解除、再ロックの指示（パスワード付き）もいれていただけますか？

これを色々な人が触ることになるので、
誤作動？をなくすために（破壊すると直せないので）、
シンプルなもの、必要箇所以外は触れないようにしたいです。

どうぞよろしくお願いいたします！

（さち） 2015/04/04(土) 20:25

すみません！
Ａ列の通し番号、最初は "1" のままで止まって
いたのですが、一度閉じてブックを開き直したら
連動していました。
ありがとうございます。
（さち） 2015/04/04(土) 21:21

 >Ａ列の通し番号、最初は "1" のままで止まって 
 > いたのですが、一度閉じてブックを開き直したら 
 >連動していました。

 実は　Sub Copy1To2() 'Sheet1 側のコマンドボタンに登録
 この中の、sh2.Range("A2").Value = myrow.Range("A1").Value
 最初は、sh2.Range("A2").Value = sh1.Range("A1").Value のままにしていて
 ここだけは、１行目の値がSheet2に転記されてしまう、おばかなコードだったので
 こっそりと（？）sh2.Range("A2").Value = myrow.Range("A1").Value　に変えたんです。
 ちゃんと、説明して変えればよかったです。

 で、シート保護解除とその再保護ですけど、ＶＢＡ内でやりたいということは

 ・保護解除（１）
 ・マクロでいろいろシートに書き込み
 ・再保護（２）

 こんなことをやりたいからですね。
 こうしてもいいですが、もう１つ、ＶＢＡには隠し技があります。
 保護を掛けたまま、でも、ＶＢＡは、したい放題、なんでもできる。一々、（１）と（２）をやる必要がなくなります。
 これが、UserInterface:=True付の保護です。
 残念ながら、この設定は操作ではできず、ＶＢＡで行う必要があるのですが、一度、こう設定しておけば
 自由自在にマクロで保護されたシートの変更ができます。
 実際には、ブックを開いたときに設定するというのがよろしいかと。

 該当のシートに、必要なシート保護条件でパスワード付保護を（手作業で）かけたうえで、
 THisWorkbookモジュール（ＶＢＥ画面のプロジェクトツリーのThisWorkbookをダブルクリック）に。
 一度、ブックを閉じて、再度開いてください。

 Private Sub Workbook_Open()
 '現在の保護要素を継承したシート保護 UserInterfaceOnly付
    Dim pp As Protection
    Dim shn As Variant

    For Each shn In Array("Sheet1", "Sheet2")   '★対象シート名。いくつでも。
        With Sheets(shn)

            Set pp = .Protection

            .Protect DrawingObjects:=.ProtectDrawingObjects, _
                        Contents:=.ProtectContents, _
                        Scenarios:=.ProtectScenarios, _
                        AllowFormattingCells:=pp.AllowFormattingCells, _
                        AllowFormattingColumns:=pp.AllowFormattingColumns, _
                        AllowFormattingRows:=pp.AllowFormattingRows, _
                        AllowInsertingColumns:=pp.AllowInsertingColumns, _
                        AllowInsertingRows:=pp.AllowInsertingRows, _
                        AllowInsertingHyperlinks:=pp.AllowInsertingHyperlinks, _
                        AllowDeletingColumns:=pp.AllowDeletingColumns, _
                        AllowDeletingRows:=pp.AllowDeletingRows, _
                        AllowSorting:=pp.AllowSorting, _
                        AllowFiltering:=pp.AllowFiltering, _
                        AllowUsingPivotTables:=pp.AllowUsingPivotTables, _
                        UserInterfaceOnly:=True, _
                        Password:="abcd"        '★パスワードは実際のものに
        End With
    Next

 End Sub

 で、ブック保存ですが、それぞれのマクロの最後の Application.Goto の上に
 ThisWorkbook.Save と入れてください。

（β） 2015/04/04(土) 21:53

（β）様
ありがとうございました！
実際のデータに当てはめてみたら
見事に動きました。感動のひとことに尽きます。
細かい解説も書いてくださって、指示の意味が
素人にも少しだけですが分かりました。
VBAやマクロが分かったら仕事もすごく楽しくなるだろう
思います。
本当にありがとうございました♪

（さち） 2015/04/04(土) 23:46

コメント返信：

[ 一覧(最新更新順) ]

[[20150404140303]] 『一行を区切って数列にコピー』（さち） ページの最後に飛ぶ

[[20150404140303]]　『一行を区切って数列にコピー』（さち）　ページの最後に飛ぶ