【VBA】フィルタしたセルをコピーし、フィルタしたまま複数貼り付け

以下のような場合、マクロをどのように書けば良いか教えてください。

A列　B列　C列
あ　　１
い　　２
う　　
あ　　３
い　　４
う
※実際は1000以上行数があります

■やりたいこと
A列で「あ」でフィルタをかける
A列のフィルタがかかったままB列をコピー
C列に貼り付け
結果、以下のようになってほしいです。

A列　B列　C列　　　　　A列　B列　C列
あ　　１　　　　　　　　あ　　１　 １
あ　　３　　　　　　　　い　　２
　　　　　　　　　⇒　　う　　
　　　　　　　　　　　　あ　　３　 ３
　　　　　　　　　　　　い　　４
　　　　　　　　　　　　う

初心者なりにいろいろ試してみましたがうまくいきません。
ご教示いただけますと幸いです。
どうぞよろしくお願いいたします。

No.2 ベストアンサー 回答者： tom04 回答日時： 2018/12/06 08:28

こんにちは！

A列が「あ」であればC列がその行のB列データになれば良いのですね。
オートフィルタではなく、単に値の代入ではどうでしょうか？

No.1さんもおっしゃっているようにオートフィルタの場合は1行目が何らかの項目行になっている！というコトが前提だと思いますので、
2行目以降にデータがあるとします。

Sub Sample1()
　Dim i As Long, lastRow As Long
　Dim myR
　　lastRow = Cells(Rows.Count, "A").End(xlUp).Row
　　　myR = Range(Cells(2, "A"), Cells(lastRow, "C"))
　　　　For i = 1 To UBound(myR, 1)
　　　　　If myR(i, 1) = "あ" Then
　　　　　　myR(i, 3) = myR(i, 2)
　　　　　Else
　　　　　　myR(i, 3) = ""
　　　　　End If
　　　　Next i
　　　Range(Cells(2, "A"), Cells(lastRow, "C")) = myR
End Sub

こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

こんばんわ。ご回答ありがとうございます。お礼が遅くなり失礼いたしました。
値の代入…そんな発想思いつきもしませんでした。勉強になります。本当にありがとうございました！

お礼日時：2018/12/07 00:09

No.4 回答者： ママチャリ 回答日時： 2018/12/10 13:07

No.3です。

A列を「再販」でフィルタかけてからマクロを実行するのではないですか？
そもそも、そういうマクロを作りたいという質問でしょ！！

この回答へのお礼

フィルタをかけるところからマクロで書きたかったので…書き方が悪かったです。失礼いたしました。

お礼日時：2018/12/10 13:49

No.3 回答者： ママチャリ 回答日時： 2018/12/09 09:29

アクティブシートのフィルタ範囲を全体的に1行下げた範囲（見出し行を除くため）の可視行を対象に、B列の値をC列に移送してみました。

こんな感じです。

Sub sample()
Dim r As Range
For Each r In ActiveSheet.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Rows
Cells(r.Row, "C") = Cells(r.Row, "B")
Next r
End Sub

この回答へのお礼

こんにちは。
ご回答ありがとうございます。移送できました！
ここにA列が「再販」なら、という条件をつける場合はどうすればよろしいでしょうか。

お礼日時：2018/12/10 12:25

No.1 回答者： WindFaller 回答日時： 2018/12/06 01:23

こんばんは。

このマクロは、オートフィルターのヘッダー付きを想定して作られたものです。

aaa bbb　'←ヘッダー（先頭行の見出し）
あ 1
い 2
う　
あ 3
い 4

'FieldとCriteria1(オートフィルターの検索値）は、マニュアルで変更してください。
2000～3000行程度なら、問題はないはずですが、このマクロの限界値は、バージョンによっては、6万行ぐらいに出てくる可能性があります。その場合は、貼り付けを分割しないといけません。

それと、途中で、結合セルがあったら解決しません。

'//
Sub TestSortnCopy()
　Dim Rng As Range
　Dim Ar As Variant
　Dim cnt As Long, i As Long
　With ActiveSheet
　　If .AutoFilterMode Then
　　　.AutoFilterMode = False
　　End If
　　Set Rng = Range("A1", Cells(Rows.Count, 1).End(xlUp))
　　cnt = Rng.Rows.Count
　　ReDim Ar(cnt - 1)
　　Rng.Resize(, 2).AutoFilter _
　　　Field:=1, _
　　　Criteria1:="あ" 'オートフィルターの検索値
　　Application.ScreenUpdating = False
　　For i = 1 To cnt
　　　If Cells(i, 2).EntireRow.Hidden = False Then
　　　　Ar(i - 1) = Cells(i, 2).Value
　　　Else
　　　　Ar(i - 1) = ""
　　　End If
　　Next
　　.AutoFilterMode = False
　　.Range("C1").Resize(cnt).Value = Application.Transpose(Ar)
　　Application.ScreenUpdating = True
　End With
End Sub

この回答へのお礼

こんばんわ。早速のご回答ありがとうございます！お礼が遅くなり失礼いたしました。
実はまだ試せていないのですが…時間がかかりそうですが、1行1行理解を深めて勉強してまいります。本当にありがとうございました。

お礼日時：2018/12/07 00:07