[[20210126100012]]　『同一日付を追加』（動画ファン）　ページの最後に飛ぶ

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

　

『同一日付を追加』（動画ファン）

TV録画用の予定表を作成しています。

A列に日付を一括して入力
　a2=DATE(G2,H2,1) 

        G2:年度指定
　　H2:月指定
　a3=a2+1
      以下a40までオートフィル機能でコピー

「土曜は青、日曜は赤」予定表の曜日を色分けしたいので
「条件付き書式」と「WEEKDAY関数」を組み合わせて曜日を色分けで表示されるようにしています。
　　

時々同一日に２−３本録画予約がある場合があるので
マクロをさくせいする事にしました。

やりたいことは、
　指定日に下に新しく空行を作成して
　指定日と同じ日付をコピーする。　
　　（土曜、日曜の色分けは指定日の条件をそのまま引き次ぐ）

以下のマクロを作成しましたが
　　上手く処理されません。
　　　　　コピーしたい日付を選択してマクロを起動しても指定日の上に空欄ができるだけで
　　　　　日付が何もコピーされない。

　　コードの修正はどうすれば良いですか　？

Sub Macro3()
'
' Macro3 Macro
' 

    ActiveCell.Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Rows(ActiveCell.Row - 1).Select
    Selection.Copy
    ActiveSheet.Paste
End Sub
　
　

　

＜ 使用 Excel：Excel2019、使用 OS：Windows10 ＞

VBAの世界では基本的に、シートやセルを明示すれば、いちいちアクティブにしたり選択したりする必要はありません。
ただ、今回の作業はほぼActiveCellの操作してかしてないので↓のようにすればいいんじゃないですか？ 
    Sub さんぷる()
        ActiveCell.Copy
        ActiveCell.Insert Shift:=xlDown
        Application.CutCopyMode = False
    End Sub

（もこな２） 2021/01/26(火) 12:28

コードの提示ありがとうございます。

コードを検証すると
　例えば、A32（３月３日）を選択してマクロを実行すると
　A3１，A32が3月2日（A33が3月3日）となり
　　　指定したセルの1日前が追加された形式になってしまいます。

（動画ファン） 2021/01/26(火) 13:11

検索して利用できそうなコードを繋ぎ合わせて以下のマクロを検証中です。
一応、上手く処理できてそうですが
　改良点やアドバイスあればお願いします。

Sub RowsInsert_2()
'
Dim RowsNo As Long
Dim xCount As Integer
Dim ROOP As Integer

KAISUU:
xCount = Application.InputBox("追加行数の数は　？", "追加行数", , , , , , 1) 

    If xCount < 1 Then
        MsgBox "追加行数は１以上です。指定回数を見直してください。", vbInformation, "追加行数のミス"
        GoTo KAISUU
    End If

For ROOP = 1 To xCount 

    RowsNo = ActiveCell.Row + 1
    Rows(RowsNo).Select
    Selection.Insert Shift:=xlDown


    Cells(RowsNo, 1) = Cells(RowsNo - 1, 1).Value
    'Cells(RowsNo, 2) = Cells(RowsNo - 1, 2).Value
Next ROOP

End Sub

（動画ファン） 2021/01/26(火) 13:39

ループの回数を1-5に固定するため以下に修正しました。

Sub RowsInsert_2()
'
Dim RowsNo As Long
Dim xCount As Integer
Dim ROOP As Integer

KAISUU:
xCount = Application.InputBox("追加行数の数は　？", "追加行数 (1-5）", , , , , , 1) 

    '処理回数指定
    If xCount < 1 Or xCount > 5 Then
        MsgBox "追加行数は１以上５以下です。指定回数を見直してください。", vbInformation, "追加行数のミス"
        GoTo KAISUU
    End If

For ROOP = 1 To xCount 

    RowsNo = ActiveCell.Row + 1
    Rows(RowsNo).Select
    Selection.Insert Shift:=xlDown


    Cells(RowsNo, 1) = Cells(RowsNo - 1, 1).Value
    'Cells(RowsNo, 2) = Cells(RowsNo - 1, 2).Value
Next ROOP

End Sub

inputBoxでキャンセルをクリックした場合の処理を追加しようとしましたが
以下のコードでは上手くいきません。
修正できればお願いします。

KAISUU:
Do 

    xCount = Application.InputBox("追加行数の数は　？", "追加行数 (1-5）", , , , , , 1)
    '処理を強制終了
    If StrPtr(xCount) Then Exit Sub
    '処理回数指定
    If xCount < 1 Or xCount > 5 Then
        MsgBox "追加行数は１以上５以下です。指定回数を見直してください。", vbInformation, "追加行数のミス"
        GoTo KAISUU
        If IsNumeric(ans) Then flg = True
     End If
 Loop Until flg = True

（動画ファン） 2021/01/26(火) 14:49

一応、上手く処理できてそうですが
　改良点やアドバイスあればお願いします。

Sub RowsInsert_2()
'
Dim RowsNo As Long
Dim xCount As Integer
Dim ROOP As Integer

KAISUU:
xCount = Application.InputBox("追加行数の数は　？", "追加行数 (1-5）", , , , , , 1) 

    '処理キャンセル
    If xCount = 0 Then
        Exit Sub
    Else
        '処理回数は1-5でそれ以外は、再入力
        If xCount < 1 Or xCount > 5 Then
            MsgBox "追加行数は１以上５以下です。指定回数を見直してください。", vbInformation, "追加行数のミス"
             GoTo KAISUU
            End If
    End If

'行追加
For ROOP = 1 To xCount 

    RowsNo = ActiveCell.Row + 1
    Rows(RowsNo).Select
    Selection.Insert Shift:=xlDown


    Cells(RowsNo, 1) = Cells(RowsNo - 1, 1).Value
    'Cells(RowsNo, 2) = Cells(RowsNo - 1, 2).Value
Next ROOP
（動画ファン） 2021/01/26(火) 16:42
2021/01/26(火) 14:49 の投稿についてコメントします。
なお、「上手くいきません」の詳細が「If StrPtr(xCount) Then の条件分岐が想定通りに行かない」であると推測しての回答です。

恐らく、↓このあたりを参考になさったのかと思いますが、
インストラクターのネタ帳
https://www.relief.jp/docs/excel-vba-inputbox-cancel.html

同じサイト内にも記載があるように、InputBoxには2種類あります。
https://www.relief.jp/docs/excel-vba-inputbox-function-application-inputbox-method.html

動画ファンさんが現在コードに組み込んでいらっしゃる Application.InputBox と、キャンセル処理を組み込むコード内で紹介されている InputBox関数 は別物です。
（じゃふ） 2021/01/26(火) 16:48

じゃふさん、回答感謝します。

ネタ元は提示されたURLで間違いありません。

ど素人がコードの継ぎ接ぎで何とかしているので
InputBox（関数）とAppication.InputBox（メソッド）はまったくの別物
なのを同じものと思ってしまったのがコードが「上手く行かない」理由でした。

（動画ファン） 2021/01/26(火) 17:38

＞例えば、A32（３月３日）を選択してマクロを実行すると
＞A3１，A32が3月2日（A33が3月3日）となり
＞指定したセルの1日前が追加された形式になってしまいます。

それ、セルに↓のような数式が書かれてませんか？ 

 =A31+1

後段の挿入行数を指定する場合でも、ループ処理じゃなくてもよい気がします。 

    Sub さんぷる2()
        Const 挿入行数 As Long = 2


        ActiveCell.Offset(1).Resize(挿入行数).Insert Shift:=xlDown
        ActiveCell.Offset(1).Resize(挿入行数).Value = ActiveCell.Value
    End Sub

（もこな２） 2021/01/26(火) 17:57

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

それ、セルに↓のような数式が書かれてませんか？ 
 ＞=A31+1

　　最初の質問に
　　　a3=a2+1 

     　 以下a40までオートフィル機能でコピー
　　と現在の状態（条件）を記載しました。

提示されたコードを検証したいと思います。
（offset、Resizeはど素人には理解するのが現段階では難しいです。） 

 Sub さんぷる2()
        Const 挿入行数 As Long = 2
        ActiveCell.Offset(1).Resize(挿入行数).Insert Shift:=xlDown
        ActiveCell.Offset(1).Resize(挿入行数).Value = ActiveCell.Value
    End Sub
（動画ファン） 2021/01/26(火) 18:33
＞最初の質問に〜記載しました。
本当ですね。失礼しました。
であれば、（数式がコピーされちゃうので）普通のコピペではダメですね。

＞offset、Resizeはど素人には理解するのが現段階では難しいです。
わかってしまえば大したことはしてないです。

ActiveCellがA32セルだとすると 

 Offset(1) で１行したにずらすのでA33セルという意味になり
 Range("A33").Resize(挿入行数) で縦２行、横はそのままにセル範囲を変更なので、A33:A34になり、
 Range("A33:A34").Insert Shift:=xlDown でそのままA33:A34に挿入して下にずらす

という命令になってます。

（もこな２） 2021/01/27(水) 09:22

もこな２さん、コードの解説ありがとうございます。

セルに関しては、RangeやCellsまでで
　それから先のOffsetやResizeを勉強を後回しにしていました。
（こちらのような援助サイトやサイトのコードのツギハギで何とか凌いで来ました。）

何とか理解がもう少し先まで進むように努力します。

（動画ファン） 2021/01/27(水) 11:08

コメント返信：

[ 一覧(最新更新順) ]

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