###前提・実現したいこと
マクロ初心者です。
表の下に同じ表をコピーして追加する処理について。
sheet1にあるそれぞれのシート名のシートに
結果欄に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
気になる質問をクリップする
クリップした質問は、後からいつでもMYページで確認できます。
またクリップした質問に回答があった際、通知やメールを受け取ることができます。
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。
回答2件
0
やりたいことを私なりに解釈して作ってみたのですが…
こんな感じでどうでしょうか。
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
総合スコア1894
0
ベストアンサー
問題の箇所が分からない場合は、VBEの画面でF8を押し、1行ずつ確認されるのが良いかと思います。
私がパッと見た中で怪しいのは、以下の点です。
1.添付いただいているエクセルの表では、B列のデータはA001、A002、、、となっていますが、マクロ側で検索をかけているのは、A_xxxという形式です。データ側をA_001とするか、Axxxという形式にした方が良いかと思います。
2.For文のID_CountはIDCount=6 To 6+LoopCountではないでしょうか?
まず、ここまでご確認いただければと思います。
2016/9/23/6:40追記
1点気になったのですが、今回実行したいのは、「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」、「未実施」の3通りの記述があり、「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総合スコア217
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。
2016/09/22 09:38
2016/09/22 09:58
2016/09/22 10:17
2016/09/22 10:36
2016/09/22 11:58
2016/09/22 13:11
2016/09/22 13:12
2016/09/23 02:23
2016/09/23 02:28
2016/09/23 02:40
2016/09/23 03:31
2016/09/23 03:44
2016/09/23 03:55
2016/09/23 04:04
2016/09/23 05:21
2016/09/23 05:28
2016/09/23 05:35
2016/09/23 05:49
2016/09/23 05:58
2016/09/23 06:01
2016/09/23 06:31
2016/09/23 06:40
2016/09/23 06:58
2016/09/23 07:08
2016/09/23 07:24
2016/09/23 07:27
2016/09/23 07:29
2016/09/23 07:31
2016/09/23 07:34
2016/09/23 07:52
2016/09/23 08:00
2016/09/23 08:06
2016/09/23 08:43
2016/09/23 08:45
2016/09/23 10:55
あなたの回答
tips
太字
斜体
打ち消し線
見出し
引用テキストの挿入
コードの挿入
リンクの挿入
リストの挿入
番号リストの挿入
表の挿入
水平線の挿入
プレビュー
質問の解決につながる回答をしましょう。 サンプルコードなど、より具体的な説明があると質問者の理解の助けになります。 また、読む側のことを考えた、分かりやすい文章を心がけましょう。
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。
2016/09/23 11:01