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

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

ただいまの
回答率

87.60%

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

受付中

回答 1

投稿

  • 評価
  • クリップ 0
  • VIEW 2,684

score 12

前提・実現したいこと

イメージ説明
エクセルでリストを作成しており特定の列にフラグを立てています。
フラグが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

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

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

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

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 1

0

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

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

Option Explicit

Sub ColCopy()

    Dim noCol As Integer            'Noの列番号
    Dim familyNameCol As Integer    '姓の列番号
    Dim prefecturesCol As Integer   '都道府県の列番号
    Dim pasteFlagCol As Integer     '貼付けフラグの列番号
    Dim lastRow As Long             'リストの最終行
    Dim copySheet As Worksheet      'コピー元のワークシート
    Dim pasteRow As Long            '貼り付け先の行番号
    Dim pasteSheet As Worksheet     '貼り付け先のワークシート
    Dim i As Long                   'ループカウンタ

    'このサンプルコードでは、Sheet1からSheet2にコピーします。
    '実際のファイル構成に応じて編集してください。
    Set copySheet = Worksheets("Sheet1")
    Set pasteSheet = Worksheets("Sheet2")

    copySheet.Activate

    '各列名ごとに列番号を取得します。
    '将来、列の位置が移動してもコードを書き換えなくて良くなります。
    '列名が変わった場合は書き換えることになりますが、その可能性は低いでしょう。
    noCol = SearchCol("No")
    familyNameCol = SearchCol("姓")
    prefecturesCol = SearchCol("都道府県")
    pasteFlagCol = SearchCol("貼付けフラグ")

    'Noの最終行をリストの最終行としています。
    lastRow = Cells(Rows.Count, noCol).End(xlUp).Row

    'リストの最終行に行きつくまでフラグの列をチェックします。
    '1があったら貼り付け先のA列に姓、B列に都道府県をコピーします。
    pasteRow = 1
    For i = 2 To lastRow
        If Cells(i, pasteFlagCol) = 1 Then
            pasteSheet.Cells(pasteRow, 1) = Cells(i, familyNameCol)
            pasteSheet.Cells(pasteRow, 2) = Cells(i, prefecturesCol)
            pasteRow = pasteRow + 1
        End If
    Next

End Sub

Function SearchCol(colName As String)

    Dim colNum As Integer

    colNum = 1

    Do While Cells(1, colNum) <> ""
        If Cells(1, colNum) = colName Then
            Exit Do
        End If
        colNum = colNum + 1
    Loop

    SearchCol = colNum

    '一致する列名がなかった場合の処理は書いていません。
    '必要に応じて記載してください。

End Function

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

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

  • ただいまの回答率 87.60%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る