HOME > Q&A > Excel （VBA）

Excel （VBA）
Excel VBAに関するフォーラムです。
  • 掲示板への投稿には会員登録（無料）が必要です。会員登録がまだの方はこちら
  • 「掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
(Windows 10全般 : Excel 2016)
テーブルの特定の値を抽出し、そこにコピペする方法
投稿日時: 23/05/20 22:17:56
投稿者: onp

VBA初心者です。アドバイスよろしくお願いいたします。
 
Sheet1のA2:F2の中でE列に数字（ユニークキー）と同じ数字がSheet2（テーブル化しています。）のE列にあればSheet1のA2:F2をコピーしてsheet2の抽出した行に値貼り付けで上書きするマクロを作成したいのですが行き詰っています。
また、検索しユニークキーがSheet2に無い場合があり、無い場合はテーブル最終行に追加をしたいです。
アドバイスお願いいたします。
投稿日時: 23/05/20 22:24:20
投稿者: onp

onp さんの引用:
VBA初心者です。アドバイスよろしくお願いいたします。
 
Sheet1のA2:F2の中でE列に数字（ユニークキー）と同じ数字がSheet2（テーブル化しています。）のE列にあればSheet1のA2:F2をコピーしてsheet2の抽出した行に値貼り付けで上書きするマクロを作成したいのですが行き詰っています。
また、検索しユニークキーがSheet2に無い場合があり、無い場合はテーブル最終行に追加をしたいです。
アドバイスお願いいたします。

 
Sub Macro1()
    Dim frm As Variant
    Dim A As Variant
     
    With Sheet2.Range("A2:F2")
      
    '検索する氏名コードをfrmに格納
    frm = Sheet2.Range("E2").Value
    'sheet1のE列に氏名コードでフィルタでをかける
    Range("A1").ListObject.DataBodyRange.AutoFilter 5, frm
     
     
     
    A = MsgBox("上書きしますか？", vbYesNo + vbQuestion + vbDefaultButton1)
        If A = vbYes Then
        'はいボタンがクリックされた
        .Select
         Selection.Copy
        Sheets("Sheet1").Range("A1").ListObject.DataBodyRange.Select
         
         
         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
         
         
        Else
        'いいえボタンがクリックされた
 
現在こういう感じ作成しております。
回答
投稿日時: 23/05/20 23:03:57
投稿者: simple

参考にしてください。
 

Sub Macro1()
    Dim frm     As Variant
    Dim rng     As Range
    Dim r       As Range

    With Sheet1
        frm = Sheet2.Range("E2").Value
        .Range("A1").ListObject.DataBodyRange.AutoFilter 5, frm

        On Error Resume Next
        Set rng = .Range("A1").ListObject.DataBodyRange _
                .SpecialCells(xlCellTypeVisible)
        On Error GoTo 0

        If Not rng Is Nothing Then
            Set rng = Intersect(rng, .Columns(1))
            Sheet2.Range("A2:F2").Copy
            For Each r In rng
                r.PasteSpecial Paste:=xlPasteValues
            Next
        Else
            Set rng = .Cells(Rows.Count, "A").End(xlUp).Offset(1)
            Sheet2.Range("A2:F2").Copy
            rng.PasteSpecial Paste:=xlPasteValues
        End If
    End With
End Sub
AUtoFilterを元に戻したり、とか、ユーザーの意思確認とか省略しています。
投稿日時: 23/05/21 00:38:26
投稿者: onp

すごいです、どうもありがとうございます。
参考にさせて頂きます。
 
 

simple さんの引用:
参考にしてください。
 
Sub Macro1()
    Dim frm     As Variant
    Dim rng     As Range
    Dim r       As Range

    With Sheet1
        frm = Sheet2.Range("E2").Value
        .Range("A1").ListObject.DataBodyRange.AutoFilter 5, frm

        On Error Resume Next
        Set rng = .Range("A1").ListObject.DataBodyRange _
                .SpecialCells(xlCellTypeVisible)
        On Error GoTo 0

        If Not rng Is Nothing Then
            Set rng = Intersect(rng, .Columns(1))
            Sheet2.Range("A2:F2").Copy
            For Each r In rng
                r.PasteSpecial Paste:=xlPasteValues
            Next
        Else
            Set rng = .Cells(Rows.Count, "A").End(xlUp).Offset(1)
            Sheet2.Range("A2:F2").Copy
            rng.PasteSpecial Paste:=xlPasteValues
        End If
    End With
End Sub
AUtoFilterを元に戻したり、とか、ユーザーの意思確認とか省略しています。
トピックに返信