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

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

新規登録して質問してみよう
ただいま回答率
85.46%
VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

Q&A

解決済

2回答

2650閲覧

【VBA】オートフィルタの結果のうち1列分だけ別シートにコピーしたい

koburon

総合スコア30

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

0グッド

0クリップ

投稿2023/01/17 06:03

編集2023/01/17 06:10

前提

VBAで任意の日付に異動した社員リストを出力するマクロを作っています。
使用するブックは1つで、シートは以下の2枚です。

  1. 異動DB
  2. 異動者リスト

【異動DB】
イメージ説明
【異動者リスト】
イメージ説明

実現したいこと

以下の流れをくむマクロを作りたいです。
①ボタンをクリックするとフォームが開く
②異動した年月日を入力し、OKをクリックする
イメージ説明
③【異動DB】で「A列は"2"」「B列は”入力した年月日”」でオートフィルタ
④絞り込まれたD列(社員番号)の結果をコピー
⑤【異動者リスト】のA列にペーストする

※【異動者リスト】のB列から右の情報は別のマクロで記入するので、今回はA列を埋めるマクロまでとします。

該当のソースコード

VBA

1Sub idou() 2'異動者リストを作成する 3 4 '任意の日の異動者を抽出する 5 Application.ScreenUpdating = False 6 7 Dim d As Date 8 Dim dval As String 9 Dim flag As Boolean 10 Dim i As Long 11 Dim cnt As Long 12 Dim LastRow As Long 13 14 Dim strDateFormat As String 15 Dim wS1 As Worksheet 16 Dim wS2 As Worksheet 17 18 'ワークシートを変数で宣言する 19 Set wS1 = Worksheets("異動DB") 20 Set wS2 = Worksheets("異動者リスト") 21 22 flag = False 23 strDateFormat = wS1.Range("B2").NumberFormatLocal 24 25 Do While flag = False 26 dval = InputBox("基準日を入力(記入例:1900/1/1)") 27 If StrPtr(dval) = 0 Then 28 'キャンセル又は右上の×をクリックした場合 29 Exit Sub 30 ElseIf dval = "" Then 31 'なにも入力しないでOKをクリックした場合 32 MsgBox ("何も入力されていません") 33 Else 34 '上記以外 35 '入力日付は正しいものとする 36 '(必要があれば入力日付のチェックを行い、エラーなら再入力する) 37 d = CDate(dval) 38 flag = True 39 End If 40 Loop 41 42 '最終行を取得する 43 LastRow = wS2.Cells(Rows.Count, "A").End(xlUp).Row 44 45 '最終列を取得する 46 LastClm = wS2.Cells(2, Columns.Count).End(xlToLeft).Column 47 48 '異動者リストで社員番号より右をクリアする 49 If LastRow > 2 Then 50 Range(wS2.Cells(3, "B"), wS2.Cells(LastRow, LastClm)).ClearContents 51 End If 52 53 'オートフィルタで区分データを抽出する 54 '(抽出する区分は2) 55 wS1.Range("A1").AutoFilter Field:=1, Criteria1:="2" 56 57 'オートフィルタで入力した日付を抽出する 58 wS1.Range("A1").AutoFilter Field:=2, Criteria1:=Format(d, strDateFormat) 59 60 '抽出した社員番号をコピーして貼り付ける 61 wS1.Range("D1").CurrentRegion.Copy wS2.Range("A1") 62 63 Application.ScreenUpdating = True 64 65End Sub

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

上のコードを実行すると、下画像のように【異動DB】の見出しごとペーストされてしまいました。
イメージ説明

試したこと

58行目までのオートフィルタは問題なく動作しています。
CurrentRegionプロパティを使用すると、「ひとかたまりのセル範囲全部」を指定してしまうのがコピー失敗の原因と考えています。
下記の参考URLでは「コピー元のセル範囲を、アドレスで決め打ちする方法は無い」と記載されていたのですが、何か別のアプローチで、「社員番号」の1列分のみコピー&ペーストする方法をご教示いただければと思います。よろしくお願いいたします。

補足情報(FW/ツールのバージョンなど)

PC:Windows11
ソフト:Microsoft365 Excel
参考URL:
絞り込んだ結果をコピーする
社員名簿を作る ~その1~

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

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

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

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

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

guest

回答2

0

以下のようにしてください。

VBA

1Option Explicit 2 3Sub idou() 4'異動者リストを作成する 5 6'任意の日の異動者を抽出する 7 Application.ScreenUpdating = False 8 9 Dim d As Date 10 Dim dval As String 11 Dim flag As Boolean 12 Dim i As Long 13 Dim cnt As Long 14 Dim LastRow As Long 15 Dim rg As String 16 17 Dim strDateFormat As String 18 Dim wS1 As Worksheet 19 Dim wS2 As Worksheet 20 21 'ワークシートを変数で宣言する 22 Set wS1 = Worksheets("異動DB") 23 Set wS2 = Worksheets("異動者リスト") 24 25 flag = False 26 strDateFormat = wS1.Range("B2").NumberFormatLocal 27 28 Do While flag = False 29 dval = InputBox("基準日を入力(記入例:1900/1/1)") 30 If StrPtr(dval) = 0 Then 31 'キャンセル又は右上の×をクリックした場合 32 Exit Sub 33 ElseIf dval = "" Then 34 'なにも入力しないでOKをクリックした場合 35 MsgBox ("何も入力されていません") 36 Else 37 '上記以外 38 '入力日付は正しいものとする 39 '(必要があれば入力日付のチェックを行い、エラーなら再入力する) 40 d = CDate(dval) 41 flag = True 42 End If 43 Loop 44 45 '異動者リストで3行目以降をクリアする 46 wS2.Rows("3:" & Rows.Count).ClearContents 47 48 'オートフィルタで区分データを抽出する 49 '(抽出する区分は2) 50 wS1.Range("A1").AutoFilter Field:=1, Criteria1:="2" 51 52 'オートフィルタで入力した日付を抽出する 53 wS1.Range("A1").AutoFilter Field:=2, Criteria1:=Format(d, strDateFormat) 54 55 'オートフィルタ結果の行数をカウントする 56 rg = "D1:D" & wS1.Range("D1").CurrentRegion.Rows.Count 57 cnt = WorksheetFunction.Subtotal(103, wS1.Range(rg)) 58 '1行のみの場合(見出し行のみ)終了する 59 If cnt = 1 Then Exit Sub 60 61 '抽出した社員番号をコピーして貼り付ける 62 LastRow = wS1.Cells(Rows.Count, "D").End(xlUp).Row 63 wS1.Range("D1").CurrentRegion.Range("D1").Offset(1, 0).Resize(LastRow - 1, 1).Copy wS2.Range("A3") 64 65 Application.ScreenUpdating = True 66 67End Sub 68

投稿2023/01/17 07:11

tatsu99

総合スコア5470

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

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

koburon

2023/01/17 07:25

回答ありがとうございます。 3行目以降のクリアや抽出結果の行数をカウントするコードは見直していなかったので、参考になりました。 いただいたコードで一部を修正してみます。ありがとうございました。
guest

0

ベストアンサー

一番手っ取り早い手法

一列だけですよね?ちょっと見た目悪いですが手っ取り早く行うならこうでいいはずです。

VBA

1 wS1.Range("D1").CurrentRegion.Copy wS2.Range("A1") 23dim rng as range 4set rng= wS1.Range("D1").offset(1,0)'一セル下にずらす 5ws1.Range(rng,rng.end(xlDown)).Copy wS2.Range("A1")

手作業で見た時の操作としてはフィルター後にD1セルから一セル下~一番下のセルまで選択してコピーしてるのと同じ操作になります。

別解

cells.specialCellsで可視セルだけ選択することも可能です。

VBA

1 'オートフィルタで区分データを抽出する 2 3 '(抽出する区分は2) 4 5 wS1.Range("A1").AutoFilter Field:=1, Criteria1:="2" 6 7 8 9 'オートフィルタで入力した日付を抽出する 10 11 wS1.Range("A1").AutoFilter Field:=2, Criteria1:=Format(d, strDateFormat) 12 13 14 15 '抽出した社員番号をコピーして貼り付ける 16 17 wS1.Range(wS1.Cells(2,4),wS1.Cells(LastRow,4)).specialCells(xlCellTypeVisible).Copy Destination:=wS2.Range("A1") 18 19 20 21 Application.ScreenUpdating = True 22 23 24 25End Sub 26

ただし、こちらの手法はworksheet.ChangeイベントのトリガーになるらしいのでWorksheet.Changeイベントを使用している場合は使えません。

投稿2023/01/17 06:50

編集2023/01/20 00:14
pig_vba

総合スコア808

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

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

koburon

2023/01/17 07:15

回答ありがとうございます。 どちらのシートもユーザーがセルに直接文字を入力・削除は行わないことを前提とするので、Worksheet.Changeイベントは使用しないものとし、2番目のコードをさせていただきます。 こちらをベストアンサーとします。 どうもありがとうございました。
guest

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

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

ただいまの回答率
85.46%

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

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

質問する

関連した質問