質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

新規登録して質問してみよう
ただいま回答率
85.50%
マクロ

定義された処理手続きに応じて、どのような一連の処理を行うのかを特定させるルールをマクロと呼びます。

Q&A

1回答

1299閲覧

マクロ 特定のセルの値を別シートに貼り付けについて

kirinkirin333

総合スコア12

マクロ

定義された処理手続きに応じて、どのような一連の処理を行うのかを特定させるルールをマクロと呼びます。

0グッド

0クリップ

投稿2019/07/02 05:49

前提・実現したいこと

イメージ説明
エクセルでリストを作成しており特定の列にフラグを立てています。
フラグが1の行の性と都道府県だけ別のシート貼りたいのです。

いくつか調べてコードを貼り付け
指定した列だけ貼り付けるところまではできたのですが
フラグが1の行だけできないです。

特定の行だけ別シートに貼り付けのにはどうすればいいのでしょうか。

ご教授のほどよろしくお願い申し上げます。

該当のソースコード

Option Explicit

Sub ColCopy()
Dim xlBook As Workbook
Dim xlSheetOrg As Worksheet
Dim xlSheetSel As Worksheet
Dim xlSheetDst As Worksheet
Dim strDstSheetName As String
Dim rngLastRow As Range
Dim vntIndex As Variant
Dim rngIndexs As Range
Dim rngHeader As Range
Dim lngColSrc As Long
Dim lngColDst As Long
Dim rngTargetCol As Range

Set xlBook = ThisWorkbook With xlBook Set xlSheetSel = .Worksheets("列選択") Set xlSheetOrg = .Worksheets("全体リスト") End With ' コピー先シート名取得 strDstSheetName = xlSheetSel.Range("A3").Value ' コピー先シートを初期化(なければ生成) On Error GoTo ERR_DST_SHEET Set xlSheetDst = xlBook.Worksheets(strDstSheetName) With xlSheetDst .Cells.Clear End With On Error GoTo 0 ' 項目名を読み取り With xlSheetSel Set rngLastRow = .Cells(.Rows.Count, 1).End(xlUp) Set rngIndexs = .Range(.Cells(5, 1), rngLastRow) Set rngLastRow = Nothing End With ' 見出し行の取り込み Set rngHeader = xlSheetOrg.Rows(1) ' 該当列のコピー Application.ScreenUpdating = False With xlSheetDst lngColDst = 0 For Each vntIndex In rngIndexs lngColDst = lngColDst + 1 Set rngTargetCol = rngHeader.Find(CStr(vntIndex)) lngColSrc = rngTargetCol.Column rngTargetCol.EntireColumn.Copy .Cells(1, lngColDst) Set rngTargetCol = Nothing Next vntIndex Set rngIndexs = Nothing End With Application.ScreenUpdating = True GoTo PROC_END

ERR_DST_SHEET:
Set xlSheetDst = Sheets.Add(, Sheets("全体リスト"))
xlSheetDst.Name = strDstSheetName
Resume Next

PROC_END:
Set rngHeader = Nothing
Set xlSheetDst = Nothing
Set xlSheetOrg = Nothing
Set xlSheetSel = Nothing
Set xlBook = Nothing

End Sub

気になる質問をクリップする

クリップした質問は、後からいつでもMYページで確認できます。

またクリップした質問に回答があった際、通知やメールを受け取ることができます。

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

guest

回答1

0

下記にサンプルコードを作りました。
貼り付け先のシートがなかった場合の生成などは端折っています。
コード内のコメントを見ていただければ、やっていることはご理解頂けるかと思います。

質問の回答のポイントとしては、リストの最初の行から最後の行までフラグの列をチェックすることです。
そのためには、何行目が最終行なのかを先に取得しておく必要があります。
あとはループでフラグの1を探しつつ、見つかったら随時コピーするだけです。
(コピーと言っても、Copyメソッドを使わず、=で直接セルに代入させています)

VBA

1Option Explicit 2 3Sub ColCopy() 4 5 Dim noCol As Integer 'Noの列番号 6 Dim familyNameCol As Integer '姓の列番号 7 Dim prefecturesCol As Integer '都道府県の列番号 8 Dim pasteFlagCol As Integer '貼付けフラグの列番号 9 Dim lastRow As Long 'リストの最終行 10 Dim copySheet As Worksheet 'コピー元のワークシート 11 Dim pasteRow As Long '貼り付け先の行番号 12 Dim pasteSheet As Worksheet '貼り付け先のワークシート 13 Dim i As Long 'ループカウンタ 14 15 'このサンプルコードでは、Sheet1からSheet2にコピーします。 16 '実際のファイル構成に応じて編集してください。 17 Set copySheet = Worksheets("Sheet1") 18 Set pasteSheet = Worksheets("Sheet2") 19 20 copySheet.Activate 21 22 '各列名ごとに列番号を取得します。 23 '将来、列の位置が移動してもコードを書き換えなくて良くなります。 24 '列名が変わった場合は書き換えることになりますが、その可能性は低いでしょう。 25 noCol = SearchCol("No") 26 familyNameCol = SearchCol("姓") 27 prefecturesCol = SearchCol("都道府県") 28 pasteFlagCol = SearchCol("貼付けフラグ") 29 30 'Noの最終行をリストの最終行としています。 31 lastRow = Cells(Rows.Count, noCol).End(xlUp).Row 32 33 'リストの最終行に行きつくまでフラグの列をチェックします。 34 '1があったら貼り付け先のA列に姓、B列に都道府県をコピーします。 35 pasteRow = 1 36 For i = 2 To lastRow 37 If Cells(i, pasteFlagCol) = 1 Then 38 pasteSheet.Cells(pasteRow, 1) = Cells(i, familyNameCol) 39 pasteSheet.Cells(pasteRow, 2) = Cells(i, prefecturesCol) 40 pasteRow = pasteRow + 1 41 End If 42 Next 43 44End Sub 45 46Function SearchCol(colName As String) 47 48 Dim colNum As Integer 49 50 colNum = 1 51 52 Do While Cells(1, colNum) <> "" 53 If Cells(1, colNum) = colName Then 54 Exit Do 55 End If 56 colNum = colNum + 1 57 Loop 58 59 SearchCol = colNum 60 61 '一致する列名がなかった場合の処理は書いていません。 62 '必要に応じて記載してください。 63 64End Function 65

投稿2019/07/10 04:18

Secret

総合スコア220

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

まだベストアンサーが選ばれていません

会員登録して回答してみよう

アカウントをお持ちの方は

15分調べてもわからないことは
teratailで質問しよう!

ただいまの回答率
85.50%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問