[[20150807173836]]　『行列　挿入・削除のシート間連動』（まろやか）　ページの最後に飛ぶ

『行列　挿入・削除のシート間連動』（まろやか）

お世話になってます。

あるブックのシート1に合せて、
シート2に表や文字の連動をさせたいのですが、
シート1にて、行例の挿入・削除があり、連動できません。

良い方法をご存知でしたらお教え頂けますでしょうか？

＜使用 Excel：Excel2010、使用 OS：WindowsXP ＞

 要件がよくわからないのですが、
 Sheet2の各セルに、

 =IF(INDIRECT("Sheet1!"&ADDRESS(ROW(),COLUMN()))="","",INDIRECT("Sheet1!"&ADDRESS(ROW(),COLUMN())))

 とか

 =IF(INDEX(Sheet1!$A$1:$Z$1000,ROW(),COLUMN())="","",INDEX(Sheet1!$A$1:$Z$1000,ROW(),COLUMN()))

 こんな数式をぎっしりと入れておくと要件にマッチしますか？

 (式そのものはダサイので、専門家さんからスマートなものの提示を期待しますが、要件としてあっているのかどうか）

（β） 2015/08/07(金) 18:08

βさん

コメントありがとうございます。
又、お返事遅くなり申し訳御座いません。

お教え頂いた関数を試してみましたが、
希望通りの動作確認出来ました！！
本当にありがとうございます！

関数で行列の挿入・削除が出来るものなんですね～！
感動しました！！
式を勉強させて頂き、最終的にイメージしたシートを作ってみます！
ありがとうございました！！
（まろやか） 2015/08/10(月) 10:40

βさんに、お教え頂いた式を応用して、
イメージしたシートを作成するつもりでしたが、
上手く応用出来ないので、再度投稿させて頂きます。

βさんから、要件がよくわからないとのコメントを頂いてますんで、
改めて説明させて頂きます。

シート１に表があります、
シート２には、ある項目(列)以外を転記・連動したいです。
下記の場合、シート１の「さる」と「とら」の列以外を、シート２に連動させたいです。

■シート１
　　Ａ　　　Ｂ　　　Ｃ　　　Ｄ　　　Ｅ　　　Ｆ　　　Ｇ　　　Ｈ　　　・・・
１　いぬ　　ねこ　　さる　　とり　　りす　　とら　　かめ　　しか
２　 33 44 55 66　　　77 88 99 00
３ 22 33 44 55 66 77 88 99
４ 11 22 33 44 55 66 77 88
・
・
・

■シート２
　　Ａ　　　Ｂ　　　Ｃ　　　Ｄ　　　Ｅ　　　Ｆ　　　Ｇ　　　Ｈ　　　・・・
１　いぬ　　ねこ　　とり　　りす　　かめ　　しか
２　 33 44 66　　　77 99 00
３ 22 33 55 66 88 99
４ 11 22 44 55 77 88
・
・
・

また、
シート１で、行列の挿入・削除があるので、
それも込みで連動したいです。

　　　　　　　　　　　　　↓↓↓
　　Ａ　　　Ｂ　　　Ｃ　　　Ｄ　　　Ｅ　　　Ｆ　　　Ｇ　　　Ｈ　　　Ｉ　　　Ｊ・・・
１　いぬ　　ねこ　　かばさる　　とり　　りす　　とら　　やぎ　　かめ　　しか
２　 33 44 55 66　　　77 88 99 00 ・・・
３ 11 22 33 44 55 66 77 88　　・・・
・
・
・

■シート２
　　Ａ　　　Ｂ　　　Ｃ　　　Ｄ　　　Ｅ　　　Ｆ　　　Ｇ　　　Ｈ　　　Ｉ　　　Ｊ・・・
１　いぬ　　ねこ　　かばとり　　りす　　やぎ　　かめ　　しか
２　 33 44 55 77 88 00 ・・・
３ 11 22 33 55 66 88　　・・・
・
・
・

要は、
シート１の特定の項目(列)以外を、シート２にまるっと連動したいってことです。

（まろやか） 2015/08/10(月) 13:22

 そういう要件であれば、また違った式になりますね。

 ただ、特定の列を除きそれ以外をまるっと複写というのは、βには荷が重いですね。
 エキスパートさんの登場をお待ちください。

 なんとなく、タイトル行は、シート１のそれを、特定の列タイトルを除き、前詰めで転記し
 あとは、そのタイトル行を頼りに、シート１からデータを引っ張ってくるということになるんだろうと思います。

 βがやるなら、さささっとＶＢＡ処理です。

（β） 2015/08/10(月) 18:57

 一応ＶＢＡコードをアップしておきます。

 Sheet1のシートタブを右クリックしてコードの表示を選んででてきたところに以下を貼り付け。
 あとは、このＶＢＥ画面の右上のＸボタンをクリックしてシートに戻って、シート上でいろいろ
 挿入や削除や変更を行い、SHeet2を見てください。

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim z As Variant
    With Range("A1", UsedRange)
        Sheets("Sheet2").Cells.ClearContents
        Sheets("Sheet2").Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
    End With

    With Sheets("Sheet2")
        z = Application.Match("さる", .Rows(1), 0)
        If IsNumeric(z) Then .Columns(z).Delete
        z = Application.Match("とら", .Rows(1), 0)
        If IsNumeric(z) Then .Columns(z).Delete
    End With

 End Sub

（β） 2015/08/10(月) 20:10

βさん

コメントありがとうざいます！
またまた、お返事遅くなり申し訳御座いません。

お忙しい中、ＶＢＡコード作成頂き、ありがとうございます。大変感謝です！
ですので、申し上げにくいのですが、、、
お教え頂いたコードで試してみたところ、
文字の連動はしてますが、罫線の連動はしておらず、
行列の挿入削除の連動もしてない状況です。
また、消したい項目の列もそのまま連動している感じです。。。

こちらのやり方がおかしいとも思いますので、
もう一度確認次第、再度コメントさせて頂きます。

（まろやか） 2015/08/11(火) 15:55

 はい。罫線や書式連動はさせていません。
 それらも連動ということなら

 Sheets("Sheet2").Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value

 これを

 .copy Sheets("Sheet2").Range("A1")

 にしてください。ただし、計算式も連動します。ここは値だけにしたいということなら、この後にコードを少し加えればできます。

 ただ、行列削除等の連動はするはずですよ？
 タイトル行は１行目なんですよね？

（β） 2015/08/11(火) 16:03

 ↑　ただし、この処理は　"Sheet1"のセルの内容に何かしらの変更があったら自動的に行われます。
 逆にいいますと、セルの変更がない場合（書式設定のみといったもの）、自動実行はされません。

 それと・・・コードでは仮に、無視する列タイトルを"さる"と"とら"にしていますが、ここは実際のタイトル文字列にしてもらってますよね？

（β） 2015/08/11(火) 16:12

βさん

まだ確認出来てませんが、
ご質問の回答だけさせて頂きます。

＞タイトル行は１行目なんですよね？
→説明不足で申し訳御座いません。
　タイトル行は、4行目になります。が、
　表の右上（３行目の右端）に日付が入っております。

＞・コードでは仮に、無視する列タイトルを"さる"と"とら"にしていますが、
　　ここは実際のタイトル文字列にしてもらってますよね？
→ここは、実際のタイトル文字列にしてます。

■シート１
　　Ａ　　　Ｂ　　　Ｃ　　　Ｄ　　　Ｅ　　　Ｆ　　　Ｇ　　　Ｈ　　　・・・
１
２
３ 2015/8/11
４　いぬ　　ねこ　　さる　　とり　　りす　　とら　　かめ　　しか
５　 33　　 44 55 66　　　77 88 99 00
６ 22 33 44 55 66 77 88 99
７ 11 22 33 44 55 66 77 88

（まろやか） 2015/08/11(火) 18:03

 了解です。アップしたコードは１行目をチェックしていますので、どこにも "さる"や"とら"がないわけです。
 なので、それらもSHeet2に反映してしまいます。

 ここを直し、かつ、書式設定の変更だけの場合は自動反映しない部分を、ちょっと姑息な（？）方法で
 カバーしてコード再掲予定ですが、

 １行目～３行目は必ず、そのままSheet2に反映なんですね？
 仮にA4のタイトルが、"さる"でも　日付は反映ですね？

（β） 2015/08/11(火) 18:15

βさん

コメントありがとうございます。
取り急ぎですみませんが、
１行目～３行目も必ず、そのまま反映させたいです。
日付のある列は、連動させたくない列と絶対にかぶらないので大丈夫です。
（まろやか） 2015/08/11(火) 18:25

 19:41　ほんとちょっとコードを修正（Selectをなくしました）
 20:39　さらに、ちょっとだけコードをスリムに。

 A4が　さる　でも、日付を含めて１行目から３行目は、そのまま反映させています。

 書式のみの変更でも反映させるように、ちょっと「姑息」な方法をとっています。
 Sheet1 の変更時点ではSheet2に何も反映させません。でも、Sheet2を開くと反映しています。

 ・Sheet1のシートモジュールに書いたコードを消してください。
 ・新たに Sheet2のシートタブｗ右クリックし、コードの表示を選んで、そこに以下を貼り付けてください。

 Private Sub Worksheet_Activate()
    Dim z As Variant

    Application.ScreenUpdating = False

    Cells.Clear

    Sheets("Sheet1").Range("A1", Sheets("Sheet1").UsedRange).Copy
    Range("A1").PasteSpecial
    Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
    Application.CutCopyMode = False

    With Range("A1", UsedRange).Offset(3)
        z = Application.Match("さる", .Rows(1), 0)
        If IsNumeric(z) Then .Columns(z).Delete
        z = Application.Match("とら", .Rows(1), 0)
        If IsNumeric(z) Then Columns(z).Delete
    End With

 End Sub

（β） 2015/08/11(火) 19:12

βさん

コードありがとうございます！
今しがた、お教え頂いたコード実行してみました。
下記の場所で、
実行エラー1004
RangeクラスのPastSpecialメゾットが失敗しました
と、エラーが出てしまいました。。。

Range("A1").PasteSpecial Paste:=xlPasteColumnWidths

あと、１点ご質問ですが、
シート１に、「さる」「とら」の列が２つある場合も、
With Range("A1", UsedRange).Offset(3)

        z = Application.Match("さる", .Rows(1), 0)
        If IsNumeric(z) Then .Columns(z).Delete
        z = Application.Match("とら", .Rows(1), 0)
        If IsNumeric(z) Then Columns(z).Delete
    End With
このコードで消してくれますか？

（まろやか） 2015/08/12(水) 09:55

 >>RangeクラスのPastSpecialメゾットが失敗しました

 不思議ですねぇ。こちらでは問題がないので・・・
 【Sheet2】のシートモジュールに書いてもらったんですよね？

 このコードは【列幅】も、Sheet1のそれを継承しようとしています。
 もし、その必要がなければ、とりあえず、このコード自体を消して試してみてください。

 >>シート１に、「さる」「とら」の列が２つある場合も、このコードで消してくれますか？

 残念ながら、１つしか消しません。簡単なのは「さる」が２つあるなら「さる」のMATCHとDeleteを２つ、
 「とら」が３つあるなら「とら」のMATCHとDeleteを３つ書けばＯＫ。

 場合によっては１つ、場合によっては３つ、場合によっては４つ　ということなら、それ用のコードにしますけど？

（β） 2015/08/12(水) 11:32

 一応、削除したいタイトルがそれぞれ複数列あった場合も対応するコードをアップしておきます。

 Private Sub Worksheet_Activate()
    Dim z As Variant
    Dim d As Variant

    Application.ScreenUpdating = False

    Cells.Clear

    Sheets("Sheet1").Range("A1", Sheets("Sheet1").UsedRange).Copy
    Range("A1").PasteSpecial
    Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
    Application.CutCopyMode = False

    With Range("A1", UsedRange).Offset(3)
        For Each d In Array("さる", "とら")
            Do
                z = Application.Match(d, .Rows(1), 0)
                If IsError(z) Then Exit Do
                .Columns(z).Delete
            Loop
        Next
    End With

 End Sub

（β） 2015/08/13(木) 09:50

βさん

長らくお返事出来ずに、すみませんでした。。。
又、コードありがとうございました。

今しがた試してみたのですが、
やはり前回同様に、

Range("A1").PasteSpecial Paste:=xlPasteColumnWidths

実行エラー1004
RangeクラスのPastSpecialメゾットが失敗しました
と、エラーが出てしまいました。
間違い無くSheet2のシートモジュールに書いてます。。。

エラーは出るものの、転記は出来ており、
これ以上、お手を煩わせるのは大変申し訳ござませんので、
お教え頂いたコードをもとに自身で調べて頑張ってみようと思います！

長々とお付き合い頂き、本当にありがとうございました！
ただ感謝です！！

（まろやか） 2015/08/18(火) 09:16

エラーが出たまま放置してたのですが、
また必要になりそうなので、再度質問させて頂きます。

Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
実行エラー1004
RangeクラスのPastSpecialメゾットが失敗しました

が出てた原因が、完全に私のミスなんでが、、、
これ（xlPasteColumnWidths ）が、
Excel2002以降のバージョンに対応してたからみたいでした。。。
自分で最初に選んでたExcel2010になってまして、
実際はExcel2000のためエラーが出てたみたいでした。。。

どなたかExcel2000で、エラーにならない方法を教えて頂ければ幸いです。。。
お願い致します。

（まろやか） 2015/09/17(木) 17:39

1週間前の未完質問に気づかず…。もう見て下さらないかな？
Excel2000の場合、RangeのPasteSpecialに指定できるのは以下。

xlPasteAll （無指定の場合はこれ）
xlPasteFormulas
xlPasteValues
xlPasteFormats
xlPasteNotes
xlPasteAllExceptBorders

値だけ貼り付ける、xlPasteValues あたりで良いかと思います。
（???） 2015/09/25(金) 10:24

???さん
コメントありがとうございます。
早速、お教え頂いたのを試してみました。
値と罫線があるので、xlPasteAllがピッタリな感じでした。
ありがとうございます。

お陰様で上手く連動が出来たのですが、
あと数点困っていることがあります。

１．特定の文字を指定して、その上のセルに日付を表示。
　　　→シート１の「しか」の上に日付を表示してあり、仮に「さる」と「りす」を
　　　　消してシート２に連動させた場合、シート２の表は２列少ないので、Ｆ列までですが、
　　　　日付は、H列のままになので表からずれてしまいます。
　　　　「しか」は絶対に消さない項目なので、「しか」を指定して必ずその上に日付を
　　　　表示する方法は御座いますでしょうか。
　　　　決まった項目を消す他に、行の挿入・削除もありますので、文字を指定したいです。
　　
　　　Ａ　　　Ｂ　　　Ｃ　　　Ｄ　　　Ｅ　　　Ｆ　　　Ｇ　　　Ｈ　　　・・・
１
２
３　　　　　　　　　　　　　　　　　　　　　　　　　　　　　2015/8/11
４　　いぬ　　ねこ　　さる　　とり　　りす　　とら　　かめ　　しか

２．シート１の行列の幅をシート２に継承させたいのですが、
　　何か上手い方法はないでしょうか。

宜しくお願いします。　　
（まろ） 2015/09/25(金) 11:22

 すっかり見落としていました。

 (???)さん、フォローありがとうございました。

 今、手が離せない要件あり、引き続きフォローいただけたら幸甚です。

（β） 2015/09/25(金) 11:26

かならず4行目のどこかの列に「しか」があり、その上のセルに日付セット、ですね。

 Sub test()
    Dim i As Long

    For i = Cells(4, Columns.Count).End(xlToLeft).Column To 1 Step -1
        If Cells(4, i).Value = "しか" Then
            Cells(3, i).Value = Format(Now, "yyyy/m/d")
            Exit For
        End If
    Next i
 End Sub
（???） 2015/09/25(金) 11:35

幅合わせは、こんな感じでしょうか。

 Sub test2()
    Dim i As Long
    Dim wkIn As Worksheet

    Set wkIn = Sheets("Sheet1")

    For i = Cells(4, Columns.Count).End(xlToLeft).Column To 1 Step -1
        Columns(i).ColumnWidth = wkIn.Columns(i).ColumnWidth
    Next i
 End Sub
（???） 2015/09/25(金) 11:41

βさん
コメントありがとうございます。
気にかけて下さり恐縮です。感謝です。

???さん
コメント＆コードありがとうございます。
今しがた動作確認してみましたところ、
私の説明不足による不具合を確認しました。
まず、日付セットですが、
シート１にすでに日付がありますので、連動用のシート２に新たに日付を
追加するのでは無く、シート１にある日付を使用したいです。
シート２はシート１をコピー連動してますので、日付が２個になってしまいます。
次に、幅合せですが、
シート２は、シート１特定の項目が消えた連動ですので、
項目に対しての幅がずれてしまいます。
４列目の項目目をにて列幅を制御するのは難しいでしょうか。。。

申し訳御座いませんが、宜しくお願いします。
（まろやか） 2015/09/25(金) 13:54

Sheet1のどこに日付が入っているかは不変ではないでしょうか？不変ならば、Sheets("Sheet1").Range("A1")のように参照するだけですが…。
とりあえず、Sheet1の4行目、どこかにある「しか」の列を探し、その上の日付をSheet2の4行目、どこかにある「しか」の列に代入する例。

 Sub test()
    Dim i As Long
    Dim dw As Date

    With Sheets("Sheet1")
        For i = .Cells(4, .Columns.Count).End(xlToLeft).Column To 1 Step -1
            If .Cells(4, i).Value = "しか" Then
                dw = .Cells(3, i).Value
                Exit For
            End If
        Next i
    End With

    For i = Cells(4, Columns.Count).End(xlToLeft).Column To 1 Step -1
        If Cells(4, i).Value = "しか" Then
            Cells(3, i).Value = dw
            Exit For
        End If
    Next i
 End Sub

幅を合わせるほうの例。

 Sub test2()
    Dim i As Long
    Dim j As Long
    Dim jMax As Long
    Dim cw As String

    With Sheets("Sheet1")
        jMax = .Cells(4, .Columns.Count).End(xlToLeft).Column
        For i = Cells(4, Columns.Count).End(xlToLeft).Column To 1 Step -1
            cw = Cells(4, i).Value
            For j = 1 To jMax
                If .Cells(4, i).Value = cw Then
                    Columns(i).ColumnWidth = .Columns(j).ColumnWidth
                    Exit For
                End If
            Next j
        Next i
    End With
 End Sub
（???） 2015/09/25(金) 14:21

???さんコメントありがとうございます。
また、返答遅くなり申し訳ございません。

まずご質問の件ですが、シート１の日付は不変ではないです。
しかし、３行目というのは不変です。列だけかわります。

次に、お教え頂いたコードを試してみたところ、
シート２の４行目にある「しか」の上に日付が表示されましたが、
もともと？の日付も表示されたままになってます。
つまり、日付が二つ表示されています。
シート１のT4が「しか」だとすると、シート１の日付はT3にあります。
これでシート２を選択すると、シート２は何列か消えますので、
「しか」はP4になりますが、このとき日付はP3とT3の二箇所に表示となってます。。。
また、幅の方はシート２が全部同じ幅になってしまいます。

（まろやか） 2015/09/26(土) 13:55

Sheet2のT4セルに既に日付が入っている、というのはよく判りません。他の処理でセットしている？
列を消しているのだから、日付も一緒になって詰まっているはずですよね？
それでも、セル位置固定ならば、Range("T4") = "" とかするだけで消せると思いますが。

test2の方は、以下が変数間違いでした。すいません。

                If .Cells(4, i).Value = cw Then
                            ↓こうですね。
                If .Cells(4, j).Value = cw Then
（???） 2015/09/28(月) 09:09

???さん
コメントありがとうございます。
現状の処理を下に示します。βさん&???さんにお教え頂いた内容そのままです。

Private Sub Worksheet_Activate()

    Dim z As Variant
    Dim d As Variant
    Dim i As Long
    Dim dw As Date
    Dim j As Long
    Dim jMax As Long
    Dim cw As String

    Application.ScreenUpdating = False

    Cells.Clear

    Sheets("シート１").Range("A1", Sheets("シート１").UsedRange).Copy
    Range("A1").PasteSpecial Paste:=xlPasteAll
    Application.CutCopyMode = False

    With Range("A1", UsedRange).Offset(3)
        For Each d In Array("さる", "とら", "ひつじ")
            Do
                z = Application.Match(d, .Rows(1), 0)
                If IsError(z) Then Exit Do
                .Columns(z).Delete
            Loop
        Next
    End With

    With Sheets("シート１")
        For i = .Cells(4, .Columns.Count).End(xlToLeft).Column To 1 Step -1
            If .Cells(4, i).Value = "しか" Then
                dw = .Cells(3, i).Value
                Exit For
            End If
        Next i
    End With

    For i = Cells(4, Columns.Count).End(xlToLeft).Column To 1 Step -1
        If Cells(4, i).Value = "しか" Then
            Cells(3, i).Value = dw
            Exit For
        End If
    Next i

    With Sheets("シート１")
        jMax = .Cells(4, .Columns.Count).End(xlToLeft).Column
        For i = Cells(4, Columns.Count).End(xlToLeft).Column To 1 Step -1
            cw = Cells(4, i).Value
            For j = 1 To jMax
                If .Cells(4, j).Value = cw Then
                    Columns(i).ColumnWidth = .Columns(j).ColumnWidth
                    Exit For
                End If
            Next j
        Next i
    End With

End Sub

なぜかシート２に日付が２個に増えてしまいます。
セル位置は、行は固定ですが列が変わってきます。

幅については、ほぼほぼシート１と連動してますが、なぜか微妙に異なる感じになってます。
消えた列以降が連動してないようです。

（まろやか） 2015/09/28(月) 10:58

あれ、ホントですね。列削除しているのに、3行目は削除されず、日付が元の位置のままになりますね。
ならば、Sheet1からコピーする箇所をすこし変えて、以下ではどうでしょうか。
（Sheet1で「しか」を見つけたのと同じセル位置のSheet2の内容をコピー後、消してしまう）

    With Sheets("シート１")
        For i = .Cells(4, .Columns.Count).End(xlToLeft).Column To 1 Step -1
            If .Cells(4, i).Value = "しか" Then
                dw = Cells(3, i).Value
                Cells(3, i).Value = ""
                Exit For
            End If
        Next i
    End With

    For i = Cells(4, Columns.Count).End(xlToLeft).Column To 1 Step -1
        If Cells(4, i).Value = "しか" Then
            Cells(3, i).Value = dw
            Exit For
        End If
    Next i
（???） 2015/09/28(月) 13:07

最初のほうから読んでみて気づきましたが、A1セルからデータが詰まっているよう説明した際のコーディングを、
A4セルからデータが詰まっている状況で利用したのですね。そのせいで、表の範囲指定がおかしくなっているのでしょう。
（幅が合わないのは、4行目より長い行があるのではないですか？）

Private Sub Worksheet_Activate()

    Dim z As Variant
    Dim d As Variant
    Dim i As Long
    Dim j As Long
    Dim jMax As Long
    Dim cw As String

    Application.ScreenUpdating = False
    Cells.Clear

    Sheets("シート１").Range("A4", Sheets("シート１").UsedRange).Copy
    Range("A1").PasteSpecial Paste:=xlPasteAll
    Application.CutCopyMode = False

    With Range("A4", UsedRange)
        For Each d In Array("さる", "とら", "ひつじ")
            Do
                z = Application.Match(d, .Rows(4), 0)
                If IsError(z) Then Exit Do
                .Columns(z).Delete
            Loop
        Next
    End With

    With Sheets("シート１")
        jMax = .Cells(4, .Columns.Count).End(xlToLeft).Column
        For i = Cells(4, Columns.Count).End(xlToLeft).Column To 1 Step -1
            cw = Cells(4, i).Value
            For j = 1 To jMax
                If .Cells(4, j).Value = cw Then
                    Columns(i).ColumnWidth = .Columns(j).ColumnWidth
                    Exit For
                End If
            Next j
        Next i
    End With
End Sub

しかしこれだったら、シート１のボタンを押すと、シートを丸ごとコピー後、不要列を削除、というほうが簡単かもですよ。
（???） 2015/09/28(月) 14:45

???さん
コメントありがとうございます。

今しがた試してみましたが、
ちょっと遠のいた感じになりました。
シート２で、「さる」「とら」「ひつじ」の項目は消えて無く、
列幅も全部バラバラになってしまいました。。。
（前回までは、消える前の列までシート１と連動してました）

4行目より長い行があるのでは？とのご質問についてですが、
表の横に印刷範囲外で計算式が確かにあります。すみません。
全部の列に式が入っているのでは無く、確認用の役割で飛び飛びである感じです。
（まろやか） 2015/09/28(月) 16:59

訂正。こんなかんじでいかがでしょう？

 Private Sub Worksheet_Activate()
    Dim z As Variant
    Dim d As Variant
    Dim i As Long
    Dim j As Long
    Dim jMax As Long
    Dim cw As String

    Application.ScreenUpdating = False
    Sheets("シート１").Cells.Copy Range("A1")

    With Range("A4", UsedRange)
        For Each d In Array("さる", "とら", "ひつじ")
            Do
                z = Application.Match(d, Rows(4), 0)
                If IsError(z) Then Exit Do
                .Columns(z).Delete
            Loop
        Next
    End With

    With Sheets("シート１")
        jMax = .Cells(4, .Columns.Count).End(xlToLeft).Column
        For i = jMax To 1 Step -1
            cw = Cells(4, i).Value
            For j = 1 To jMax
                If .Cells(4, j).Value = cw Then
                    Columns(i).ColumnWidth = .Columns(j).ColumnWidth
                    Exit For
                End If
            Next j
            If jMax < j Then
                Columns(i).ColumnWidth = .Columns(jMax + 1).ColumnWidth
            End If
        Next i
    End With

    Application.ScreenUpdating = True
 End Sub

書式合わせ技を使えれば、なんかもっとすっきりセル幅を合わせられるのかもです。

（???） 2015/09/28(月) 17:44

あ～、わかりました！
セル範囲内だけDeleteするのではなく、シート内の列全体をDeleteすれば、幅も追従しますね。
ドットが付いているのを見落としました…。

 Private Sub Worksheet_Activate()
    Dim z As Variant
    Dim d As Variant

    Application.ScreenUpdating = False
    Sheets("シート１").Cells.Copy Range("A1")

    For Each d In Array("さる", "とら", "ひつじ")
        Do
            z = Application.Match(d, Rows(4), 0)
            If IsError(z) Then Exit Do
            Columns(z).Delete
        Loop
    Next

    Application.ScreenUpdating = True
 End Sub
（???） 2015/09/28(月) 17:52

???さん
コメントありがとうございます。
また、長々お付き合い頂きありがとうございます。

訂正版で動作確認させて頂きました。
結果として、
シート２で列は消えますし、
日付も列が消えた分詰めて表示されるようになりましたが、
やはり幅の連動がなるところとならないところがある感じです。。。

因みにですが、同じ項目名があったら、
最初にある項目名だけ連動して、次にあるのは連動しないってことは
あるでしょうか？
なんとなく、
With Sheets("シート１")

        jMax = .Cells(1, .Columns.Count).End(xlToLeft).Column
        For i = jMax To 1 Step -1
            cw = Cells(1, i).Value
            For j = 1 To jMax
                If .Cells(1, j).Value = cw Then
                    Columns(i).ColumnWidth = .Columns(j).ColumnWidth
                    Exit For
                End If
            Next j
            If jMax < j Then
                Columns(i).ColumnWidth = .Columns(jMax + 1).ColumnWidth
            End If
        Next i
    End With
に変更してみたら、
先程より上手く連動するようになりました。。。
（まろやか） 2015/09/29(火) 09:28

幅合わせロジックは、削除した後のデータのある列のみ元の幅に一致させていましたが、これだと減った列の分が、
データは無いけど幅は元のままになっていたので、If jMax < j Then 以降の部分で欄外のセル幅を元シート欄外の幅
（おそらくデフォルト値）に合わせました。
項目名をキーに元を探すので、同じ項目名が存在し違う幅だった場合、追従できません。そんな条件は提示されませんでしたから…。

しかし、幅合わせが必要だったのは、Range範囲内だけ列削除したために、書式が詰まらなかったためです。
これを列全体削除に変えた（ドットを外しただけ）ので、With を無くした版では、幅合わせロジックが不要のはずなのですが？
（???） 2015/09/29(火) 10:23

???さん
コメントありがとうございます。
又、説明不足で申し訳ございません。

幅については、
先にコメントしたなんとなくの方法で、
十分イメージ通りですので、問題無いです。
ありがとうございます。

最後にもう１点お伺いしたいのですが、
シート１に設定してある、ヘッダーとフッターを
シート２に連動することは出来ますでしょうか？
お手数お掛けして申し訳御座いませんが、よろしくお願い致します。
（ま） 2015/09/29(火) 15:21

印刷レイアウトは、予めシートのコピーでSheet2を作成しておけば全く同じになるので、作り直してはいかがでしょう？
そこまで毎回マクロがごそごそ動作すべきでは無いと思いますよ。
（???） 2015/09/29(火) 15:41

???さん
コメントありがとうございます。
おはようございます。

作り直すとは全部ってことですか？
私には困難です。。。

すでにシート１には、ヘッダーとフッターが入力されてますので、
上手い具合に参照出来ないか、調べてみます。
（まろやか） 2015/09/30(水) 09:28

いやいや、作り直すのはコピー先だけ。別名にでもしておいて、元シートのコピーをするだけですよ。一瞬です。
現状、2つ目のシートがアクティブになる度にマクロが動作しています。
マクロを知らない人向けの仕組みと思いますが、ここで毎回ヘッダとフッタを合わせるのはどうか、という事です。

なので、印刷レイアウトも含めて、シート丸ごとコピーしてしまえ、と。
（マクロなしになるので、コピー後にマクロを別名にしておいたシートからコピーしましょう）
（???） 2015/09/30(水) 11:46

???さん
コメントありがとうございます。

ちょっと意味を理解出来てない現状です。。。
コピー先(シート1)を作り直すんですか？？
申し訳ないですが、もう少し詳しくお教え頂けないでしょうか。すみません。
（まろやか） 2015/09/30(水) 13:08

シート1は、コピー元ですよね？そしてマクロを記述しているシートがコピー先であり、シート2では？
手作業でシート1をコピーして、シート2という名前にする、と言ってます。それならヘッダフッタも一緒ですよね。
シートをコピーするマクロを書け、とは言っていませんよ。

コピー元のシート1にはマクロが記述されていないので、シート2を消してから新しいシート2を作ると、マクロが消えます。
そこに注意するよう書いただけです。
（???） 2015/10/01(木) 10:25

???さん
コメントありがとうございます。

先に、ヘッダー＆フッター含め全ての入力が済んだシート1を
コピーしてシート2を作成し、そのシート2に別のところから、
連動するマクロをシート2にコピーするってことですか？

シートコピー後、ヘッダーとフッターの変更が生じた場合、
シート2を削除して、新たにシート2を作成する必要がありますよね。

少し検討します。
（まろやか） 2015/10/01(木) 16:23

ヘッダ、フッタには、どういう情報を書いているのですか？　普通、変えるものではないですよね。

頻繁に変える可能性があるならば、Worksheet_Activate時ではなく、ボタンを押した場合にでも
一致させれば良いのではないでしょうか。というか、変えるならばヘッダなんて使わず、
1行目のセル等にでも内容を書いてしまうとか？
（???） 2015/10/01(木) 17:21

一応、ヘッダ、フッタを合わせるマクロ例なぞ。（動作は遅いですよ？）

 Sub teet()
    With Sheets("シート1").PageSetup
        Me.PageSetup.LeftHeader = .LeftHeader
        Me.PageSetup.CenterHeader = .CenterHeader
        Me.PageSetup.RightHeader = .RightHeader
        Me.PageSetup.LeftFooter = .LeftFooter
        Me.PageSetup.CenterFooter = .CenterFooter
        Me.PageSetup.RightFooter = .RightFooter
    End With
 End Sub
（???） 2015/10/01(木) 17:33

???さん
コメントありがとうございます。
フッターは基本、変更は無いのですが、
ヘッダーの方には、案件名とか入ってまして、
記入する人によって、情報量も変更タイミングも違ってきます。

お教え頂いたマクロを動作してみました。
仰る通り、若干動作に時間が掛かりましたが、
イメージ通りでした。ありがとうございます。

ここで一緒に印刷範囲も設定しようとし、
Me.PageSetup.PrintArea = "$A$1:$Q$47"
の一文を加えたら出来たのですが、
改ページプレビューで表示される青色の枠線（縦方向）が、
一旦 L列に移動しQ列に移動するという変な動きをしてしまいます。
無駄な動きを無くす方法はご存知ないでしょうか？

（まろやか） 2015/10/02(金) 11:55

範囲指定は、Application.ScreenUpdating = False にしている間に行っていますか？
それでも発生するならば、更に以下のように、PrintCommunicationを一時的にFalseにしてみるとどうでしょう？

    Application.ScreenUpdating = False
    Application.PrintCommunication = False
    …
    元の列削除ロジック
    …
    ActiveSheet.PageSetup.PrintArea = "$A$1:$Q$47"

    Application.PrintCommunication = True
    Application.ScreenUpdating = True
（???） 2015/10/02(金) 18:27

???さん
コメントありがとうございます。
又、大変お返事遅くなり申し訳御座いません。

お教え頂いた方法で、希望の動作確認できました。
長々とお付き合い頂き、本当にありがとうございました。ただ感謝です。
（まろやか） 2015/10/06(火) 17:59

コメント返信：

[ 一覧(最新更新順) ]

[[20150807173836]] 『行列 挿入・削除のシート間連動』（まろやか） ページの最後に飛ぶ

[[20150807173836]]　『行列　挿入・削除のシート間連動』（まろやか）　ページの最後に飛ぶ