マクロの表追加について。

###前提・実現したいこと
マクロ初心者です。
表の下に同じ表をコピーして追加する処理について。

sheet１にあるそれぞれのシート名のシートに
結果欄にOK or NGが入力されていれば表を追加するという
マクロを作成したのですが
上手く動作しません。

表を追加する箇所は一行下です。

分かりづらいかもしれませんのでエクセルの表のファイルも添付しております。
どなたか分かる方ご回答お願いします＞＜

###発生している問題・エラーメッセージ

エラーは出ていませんが、表が追加されません。

###該当のソースコード
Sub testCopy()

Dim RoopCount As Long 'ループカウンタ
Dim ID_Count As Long 'ループカウンタ
Dim ST_name As String '各試験シート
Dim Find_OK As Long 'B列OK取得
Dim Find_NG As Long 'B列NG取得
Dim Find_No As Long 'Noを特定
Dim A_LastRow As Long '最終行A列セル

With Worksheets("Sheet1")

' Sheet1のB列が空欄であればfor文を抜ける
RoopCount = Application.WorksheetFunction.CountIf(Range("B:B"), "A_*")
For ID_Count = 6 To RoopCount

' B列にシート名が記入されていれば処理を行う
If .Cells(ID_Count, 2).Value <> "" Then

' シートにOKかNGのいずれかが記入されていれば表を追加する。
ST_name = .Cells(ID_Count, 6).Value
Sheets(ST_name).Activate

Set Find_OK = Worksheets("ST_name").Columns("B:B").rngTarget.Find("OK")
Set Find_NG = Worksheets("ST_name").Columns("B:B").rngTarget.Find("NG")
If Find_OK Or Find_NG Is Nothing Then
    
' A列の表の最初の行であるNoを特定
 Set Find_No = Worksheets(ST_name).Columns("A").Find(What:="No", LookAt:=xlWhole)
' 表をコピー
If Find_No Is Nothing Then
   Cells(Cells(Find_No, 1), Cells(Find_No + 9, 2)).Copy
              
   ' A列備考の最終行を特定
   A_LastRow = Worksheets(ST_name).Cells(Rows.Count, 1).End(xlUp).Row
   If A_LastRow = "備考" Then
      '貼り付け
      Worksheets(ST_name).Cells(A_LastRow + 2, 1).Paste

      'コピーしたマクロの記入欄に入力されている値を削除する
      Worksheets("Sheet1").Activate
      Worksheets("Sheet1").Range(Cells(A_LastRow + 2, 2), Cells(A_LastRow + 10, 2)).Clear
   End If

End If

End If

End If

Next

End With

End Sub

行動規範の内容に同意します

回答2件

やりたいことを私なりに解釈して作ってみたのですが…
こんな感じでどうでしょうか。

Option Explicit
Sub testCopy()
    Dim ID_Count As Long 'ループカウンタ
    Dim ST_name As String '各試験シート
    Dim A_LastRow As Long '最終行A列セル

    '念のため"sheet1"をアクティブ
    Sheets("sheet1").Select
    
    'セル"B5"が空でないとして、矩形範囲でセル最大番地を求める
    For ID_Count = 6 To Range("B5").CurrentRegion.Rows.Count + 4    'セルの個数を数えているので4を加えて番地にする
        'B列に記載されているシートが必ず存在する前提(存在チェックは省略)

        '編集対象シートを選択
        Sheets(Cells(ID_Count, 2).Value).Select

        'A列末尾のセル番号を取得
        '途中に空白があるのでCurrencRegionは使えない
        A_LastRow = Range("A65536").End(xlUp).Row
 
        '結果欄は常に最終列番号の2つ上の列
        If Cells(A_LastRow - 2, 2).Value = "OK" Or Cells(A_LastRow - 2, 2).Value = "NG" Then
            'コピー＆ペースト
            Range(Cells(A_LastRow - 9, 1), Cells(A_LastRow, 2)).Copy Cells(A_LastRow + 1, 1)
                    
            'ペーストした部分の値のクリア
            Range(Cells(A_LastRow + 2, 2), Cells(A_LastRow + 10, 2)).ClearContents
        End If
                
        '次のシート名取得処理があるので一度"sheet1"に戻す
        Sheets("sheet1").Select
    Next
End Sub

フォーマット決め打ち前提のコードです。

投稿2016/09/23 05:51

ynakano

総合スコア1894

Arisa

2016/09/23 11:01

ありがとうございます！ちょうど投稿くださった頃に完成しました…せっかくご回答頂いたのに申し訳ないです…; でもこういう書き方もあるのですね。私のより凄くスマートですっきりしてます。また上司から高速化や何かしら依頼が来るかもしれませんので(結構改善の指摘がくるので)、その時はこちらの方も参考にさせて頂きます。ありがとうございました。

行動規範の内容に同意します

ベストアンサー

問題の箇所が分からない場合は、VBEの画面でF8を押し、１行ずつ確認されるのが良いかと思います。
私がパッと見た中で怪しいのは、以下の点です。
１．添付いただいているエクセルの表では、B列のデータはA001、A002、、、となっていますが、マクロ側で検索をかけているのは、A_xxxという形式です。データ側をA_001とするか、Axxxという形式にした方が良いかと思います。
２．For文のID_CountはIDCount=6 To 6+LoopCountではないでしょうか？
まず、ここまでご確認いただければと思います。

2016/9/23/6:40追記
１点気になったのですが、今回実行したいのは、「OKか、NGが記入されている場合に、表を追加する」ということですよね？であれば、

VBA
1If Find_OK Is Nothing Or Find_NG Is Nothing Then

ではなく、

VBA
1If Not Find_OK Is Nothing Or Find_NG Is Nothing Then

ということではないでしょうか。
If Notにしないと、Find_OKか、Find_NGに値がある時はEnd Ifに飛んでしまいます。
Then～の記述を見ると、Find_OKかFind_NGに値がある時にNoをコピーして表を最終行の下に張り付けたいのかと思いますので、上述のように変更してステップ実行してみてください。

また、全体的に見ていて気になった点を以下、先に記載しておきます。
Find_Noは、それ以降のコードを見る限りRangeオブジェクトではなく、A列のNOの行を取得したいということかと思いますので、

VBA
1Find_No = Worksheets(ST_name).Columns("A").Find(What:="No", LookAt:=xlWhole).Row

にする必要があります。

また、当該範囲のコピーの書き方は、Cellsではなく、Rangeで以下のように記載します。

VBA
1Range(Cells(Find_No, 1), Cells(Find_No + 9, 2)).Copy

また、以下のコードですが、A_LastRowは、行数で数値ですので、恐らく

VBA
1If A_LastRow = "備考" Then

ではなく、

VBA
1If Cells(A_LastRow, 1) = "備考" Then

かと思います。

貼り付けのコードも、Pasteは使えませんので、以下に変更した方が良いかと思います。

VBA
1Range(Cells(A_LastRow + 2, 1), Cells(A_LastRow + 11, 2)).PasteSpecial

2016/9/23/18:20
［試験合否の記入欄］というのは、「結果」の欄で間違いないでしょうか？
つまり、「結果」の欄には、「OK」、「NG」、「未実施」の３通りの記述があり、「OK」、「NG」の場合は、表を追加し、「未実施」の場合は、表を追加しない、という認識で間違いなければ、以下のコードでお試しください。
現在例として示されているエクセルの表と同様のものをこちらでも作成し、動作検証しました。

VBA
1Option Explicit
2
3Sub testCopy()
4
5Dim LoopCount As Long 'ループカウンタ
6Dim ID_Count As Long 'ループカウンタ
7Dim ST_name As String '各試験シート
8Dim Find_OK As Range 'B列OK取得
9Dim Find_NG As Range 'B列NG取得
10Dim No As Range 'B列未実施取得
11Dim Find_No As Long 'Noを特定
12Dim A_LastRow As Long '最終行A列セル
13
14Worksheets("Sheet1").Activate
15With Worksheets("Sheet1")
16
17' Sheet1のB列が空欄であればfor文を抜ける
18LoopCount = Application.WorksheetFunction.CountIf(Range("B:B"), "A*")
19For ID_Count = 6 To 6 + LoopCount
20
21' B列にシート名が記入されていれば処理を行う
22If .Cells(ID_Count, 2).Value <> "" Then
23
24' シートにOKかNGのいずれかが記入されていれば表を追加する。
25ST_name = .Cells(ID_Count, 2).Value
26Sheets(ST_name).Activate
27
28Set Find_OK = Worksheets(ST_name).Columns("B:B").Find("OK", lookat:=xlWhole)
29Set Find_NG = Worksheets(ST_name).Columns("B:B").Find("NG", lookat:=xlWhole)
30Set No = Worksheets(ST_name).Columns("B:B").Find(what:="未実施", lookat:=xlWhole)
31
32Find_No = Worksheets(ST_name).Columns("A").Find(what:="No", lookat:=xlWhole).Row
33
34If (Not Find_OK Is Nothing Or Not Find_NG Is Nothing) And No Is Nothing Then
35Range(Cells(Find_No, 1), Cells(Find_No + 9, 2)).Copy
36
37' A列備考の最終行を特定
38A_LastRow = Worksheets(ST_name).Cells(Rows.Count, 1).End(xlUp).Row
39If Cells(A_LastRow, 1) = "備考" Then
40'貼り付け
41Range(Cells(A_LastRow + 2, 1), Cells(A_LastRow + 11, 2)).PasteSpecial
42
43'コピーしたマクロの記入欄に入力されている値を削除する
44Worksheets(ST_name).Range(Worksheets(ST_name).Cells(A_LastRow + 2, 2), Worksheets(ST_name).Cells(A_LastRow + 10, 2)).ClearContents
45
46End If
47
48End If
49
50End If
51
52Next
53
54End With
55
56End Sub
57

投稿2016/09/22 05:57

編集2016/09/23 09:27

cesolution

総合スコア217

Arisa

2016/09/22 09:27

ご回答ありがとうございます！１．検索をかけているシート名は「＿」はいりませんでしたね；ありがとうございます。 2.　修正しました！ここまで修正してまだ「' シートにOKかNGのいずれかが記入されていれば表を追加する。」の「Sheets(ST_name).Activate」でインデックスが有効範囲にありませんというエラーが出ます。ここからはWorksheets("ST_name").で指定しているのでここの「Sheets(ST_name).Activate」は不要でしょうか？

cesolution

2016/09/22 09:38

以下のマクロの部分で、F列の値をシート名として代入していますが、エクセルファイル側でF列にはシート名が無いように見えます。 ' シートにOKかNGのいずれかが記入されていれば表を追加する。 ST_name = .Cells(ID_Count, 6).Value ID_Countの行のF列に、シート名が入力されているかご確認ください。

Arisa

2016/09/22 09:58

ご指摘の通り記入されていませんでした。B列でしたので２でした；ありがとうございます。 ' シートにOKかNGのいずれかが記入されていれば表を追加する。 Set Find_OK = Worksheets("ST_name").Columns("B:B").Find("OK", LookAt:=xlWhole)←（少し修正） Set Find_NG = Worksheets("ST_name").Columns("B:B").Find("NG", LookAt:=xlWhole)←（少し修正）のでインデックスが有効範囲にありませんとなります… 下にある表の結果欄のOKかNGを検索したいので検索の順序を指定する逆方向の「SearchDirection xlNext ＝ xlPrevious 」を入れるべきでしょうか？

cesolution

2016/09/22 10:17

Worksheets("ST_name")としてしまうと、ST_nameという名前のシートに対する操作になってしまいますので、まずはWorksheets(ST_name)にしてみてください。

Arisa

2016/09/22 10:36

修正しました！次は If Find_OK Or Find_NG Is Nothing Then でひっかかってしまいます… 一行一行でひっかかってその度に申お手数おかけしてしまい申し訳ないです…

cesolution

2016/09/22 11:58

この行は、書き方の問題かと思います。以下に書き換えてください。 If Find_OK Is Nothing Or Find_NG Is Nothing Then また、もしrangeオブジェクトが正しく読み込めていないようであれば、VBEの表示→ローカルウィンドウを呼び出して、F8で１行ずつ走らせながら、If Find_OK...の部分まで進んだ段階で、Find_OKとFind_NGに、なにが入っているかご確認ください。

Arisa

2016/09/22 13:11

修正しましたが、エラーは出なくても動作はしてくれませんでした。せっかく回答くださってるのに今外出先からスマホから遠隔操作でやってる事もあり、返信遅くなって申し訳ないです; ご回答すごく助かってます

Arisa

2016/09/22 13:12

帰宅したらステップイン(？)でやってみます。

Arisa

2016/09/23 02:23

ご回答ありがとうございます！修正して実行したところ Find_No = Worksheets(ST_name).Columns("A").Find(What:="No", LookAt:=xlWhole).Row のところでひっかかります＞＜あとステップインで一行ずつしてみたのですが、 Find_OK = Worksheets(ST_name).Columns("B:B").Find("OK", LookAt:=xlWhole) Find_OK = Worksheets(ST_name).Columns("B:B").Find("OK", LookAt:=xlWhole) のところでFind_OKがNothingとなって何も入っていないようなのですがどこかおかしいところありますでしょうか？ Findの中身ですかね・・・？

Arisa

2016/09/23 02:28

もう一度試したところ Find_OK = Worksheets(ST_name).Columns("B:B").Find("OK", LookAt:=xlWhole) にはOKが入ってました！

cesolution

2016/09/23 02:40

見落としていましたが、Dim Find_OK As Long ではなく、Dim Find_OK As Range、同様に、Dim Find_NG As Rangeとしてください。また、Find_No =...の部分でひっかかる際のエラーメッセージは何でしょうか？

Arisa

2016/09/23 03:31

Rangeに修正しました！ Worksheets(ST_name).Columns("B:B").Find("OK", LookAt:=xlWhole)のところですが大文字にしたところwhatとlookatを小文字にしたところ無事通りました！

Arisa

2016/09/23 03:44

一シート目には表が追加できるようになったのですが、次のシートから追加されてません・・・エラーは出ないのに・・・。

cesolution

2016/09/23 03:55

1シート目はできるようになったということであれば、For文に問題があるか、他のシートにOKやNGが入っていないかだと思いますが、、、。ちなみに、以下のコードはなにを行うコードでしょうか？ Worksheets("Sheet1").Range(Cells(A_LastRow + 2, 2), Cells(A_LastRow + 10, 2)).Clear パッと見、添付いただいたエクセルファイルの中でSheet1に消すべきデータは無いように見受けられますが。

Arisa

2016/09/23 04:04

追加する表は記入欄に何も記入していない新しい状態にしたかったので、コピーした表の中身の値を削除する為に追加しました。でもそれだと罫線も削除されてしまうので先程 Worksheets(ST_name).Range(Worksheets(ST_name).Cells(A_LastRow + 2, 2), Worksheets(ST_name).Cells(A_LastRow + 10, 2)).ClearContentsに修正しました。 For文ですね。ちょっと見直してきます。

cesolution

2016/09/23 05:21

あと、LoopCountが、A001～A010までのカウント数である10になっているかどうかも確認してみてください。

cesolution

2016/09/23 05:28

度々すみません、１点私のご提案したコードで誤りがございました。申し訳ございません、Find_NG側にNotがついていませんでした。 If Not Find_OK Is Nothing Or Find_NG Is Nothing Then を If Not Find_OK Is Nothing Or Not Find_NG Is Nothing Then にご変更ください。

Arisa

2016/09/23 05:35

If Not Find_OK Is Nothing Or Not Find_NG Is Nothing Thenは変更済みなので大丈夫でした。また別のところですが Range(Find(what:="OK", lookat:=xlWhole), Cells(Find_No + 9, 2)).Copy でひっかかります。 SubまたはFanctionが定義されていませんと出るのですが…先程は通ったので別のところが原因でしょうか？

cesolution

2016/09/23 05:49

Worksheets(ST_name).Cells(Find....)と変更して、実行してみてください。

Arisa

2016/09/23 05:58

Worksheets(ST_name).Cells(Find(what:="OK", lookat:=xlWhole), Cells(Find_No + 9, 2)).Copyに変更しましたが変化はありません… 二つ目のCellsの前にWorksheets(ST_name).を入れたり試してみたのですが。

cesolution

2016/09/23 06:01

すみません、書き方が中途半端でした。以下のようにしてみてください。 Range(Worksheets(ST_name).Cells.Find(what:="OK", lookat:=xlWhole), Cells(Find_No + 9, 2)).Copy

Arisa

2016/09/23 06:31

先ほどのところは通りました！先程修正した ' コピーしたマクロの記入欄を削除する Worksheets("Sheet1").Range(Worksheets(ST_name).Cells(A_LastRow + 2, 2), Worksheets(ST_name).Cells(A_LastRow + 10, 2)).ClearContents でインデックスが有効範囲にありませんと出ます・・・

cesolution

2016/09/23 06:40

コピーしたデータの入力値を消すのであれば、Worksheets("Sheet1")ではなく、Wokrsheets(ST_name)かと思います。以下ではどうでしょうか？ Worksheets(ST_name).Range(Worksheets(ST_name).Cells(A_LastRow + 2, 2), Worksheets(ST_name).Cells(A_LastRow + 10, 2)).ClearContents

Arisa

2016/09/23 06:58

表を追加するところまでは出来ました。でも何故か全シートには反映されず… 一行ずつ走らせたところ ID_Count = 6 To 6 + RoopCountの ID_Count に0が入っていたのでここが原因でしょうか？ ID_Count

cesolution

2016/09/23 07:08

そうですね、マクロは、Sheet1を選択な状態で実行し、B6～B15の間にA001～A010は間違いなく入っているでしょうか？もし上記の条件が揃っていれば、For ID_Count = 6 To RoopCountに入った時点でRoopCount=10となっているはずですので、マクロをSheet1で実行しているか、Sheet1のB6～B15にシート名が間違いなく入っているかご確認ください。

Arisa

2016/09/23 07:24

追加で '試験合否の記入欄が(未実施)であれば表の追加を行わない Set No = Worksheets(ST_name).Columns("B").Find(what:="(未実施)", lookat:=xlWhole) ElseIf No Is Nothing Then End If という処理を追加したのですが Set No = Worksheets(ST_name).Columns("B").Find(what:="(未実施)", lookat:=xlWhole)でひっかかります。どこかおかしいところはありますでしょうか？ OK・NG取得でこのようなコードがあったので、コピーして中身の値を変えただけなので問題ないと思ったのですが…。 RoopCountのところもう一度確認してみます。

Arisa

2016/09/23 07:27

↑の件、変数定義のところでObjectにしたら通りました！

cesolution

2016/09/23 07:29

"No"は宣言してありますでしょうか？ Dim No As Rangeを冒頭で宣言していないようであれば、こちらを追加してみてください。

Arisa

2016/09/23 07:31

追加したら通りましたが、、、未定義であれば表は追加しないのですが、追加されてしまいます…

Arisa

2016/09/23 07:34

ElseIf 「Not」 No Is Nothing Thenで「Not」追加したのですが駄目みたいで・・・・ Is Nothingを使用すること自体がいけないのでしょうか？

cesolution

2016/09/23 07:52

OKか、NGが入っていれば追加するが、未実施の場合は追加しないということであれば、 If Not Find_OK Is Nothing Or Not Find_NG Is Nothing Then を、 If (Not Find_OK Is Nothing Or Not Find_NG Is Nothing) And No Is Nothing Then に変更したらいかがでしょうか。

Arisa

2016/09/23 08:00

変更しましたが、やっぱり追加されてしまいます… やっぱり最後に未実施はスキップする処理を入れたほうがいいのでしょうか？

cesolution

2016/09/23 08:06

NOにRangeオブジェクトが入っていればスキップされるはずです。ステップ実行で、If (Not...の段階でNOに未実施が入っているかご確認ください。また、上記のIf文の判断の手前に Set No = Worksheets(ST_name).Columns("B").Find(what:="(未実施)", lookat:=xlWhole) が入っていることをご確認ください。全体のコードが現状どうなっているのか見えにくくなっていますので、もし問題が継続する場合は、全体のコードを、「情報の追加」で上げてもらえますでしょうか。

Arisa

2016/09/23 08:43

何となく原因が分かったような気がするのですが、もしかしたら '試験合否の記入欄が(未実施)であれば表の追加を行わない Set No = Worksheets(ST_name).Columns("B").Find(what:="(未実施)", lookat:=xlWhole) ElseIf No Is Nothing Then End If の処理を一番最後に入れてしまっているからでしょうか？表を追加してしまった後にこの処理があるので…

Arisa

2016/09/23 08:45

For ID_Count = 6 To 6 + RoopCount　ですが ID_Countに6が入っています。 6 + RoopCountとしているからでしょうか？でもFor ID_Count = 6 To RoopCountにすると ID_Count =　には0が入ってきます。

Arisa

2016/09/23 10:55

無事動作しました！ RoopCountのところもちょっと変えてみたり、あとで追加した未実施のところが処理が重複してたりしたのでいろいろと見直してみました。本当に長々と付きあわせてしまって申し訳ないです。仕事で今日までが期限だったのですが、おかげで間に合いました( ; ; ) 実際仕事で使うものはシート数も多くて少しだけ違うのですが、この表とほぼ同じような処理を行ってるのでcesolutionさんの迅速な回答や適確な指摘は大変助かりました。本当にありがとうございました。

行動規範の内容に同意します

あなたの回答