セルの値をCriteriaに入れる

質問

オートフィルターでセルの値をCriteriaに入れるマクロを教えて下さい。

回答No.3

Wendy02

補足です。

#1のマクロを読みきれているのかは分かりませんが、#2の表のようなものを想定して、以下のマクロを作ってみました。すぐに出来ると思いましたが、なかなかそうはいきませんでした。

Sub TestMacro1()
　　Dim iSh As Worksheet
　　Dim kSh As Worksheet
　　Dim myData As Range
　　Dim c As Variant
　　Dim i As Long
　　Dim j As Long
　　Set iSh = Worksheets("一覧表")
　　Set kSh = Worksheets("記入用")
　　Application.ScreenUpdating = False

　　With iSh
　　'検索用のデータの抽出
　　If .AutoFilterMode = True Then .AutoFilterMode = False
　　　　With .Range("G1", .Range("G65536").End(xlUp))
　　　　　　.AdvancedFilter _
　　　　　　Action:=xlFilterCopy, _
　　　　　　CopyToRange:=.Range("AZ1"), _
　　　　　　Unique:=True
　　　　End With
　　　　Set myData = .Range("AA2", .Range("AA65536").End(xlUp))
　　　　'オートフィルタで抽出
　　　　For Each c In myData
　　　　　　.Range("D1", .Range("G65536").End(xlUp)).AutoFilter _
　　　　　　Field:=4, _
　　　　　　Criteria1:=c.Value
　　　　　　With .AutoFilter.Range.SpecialCells(xlCellTypeVisible)
　　　　　　'抽出行の最後の行+1
　　　　　　　　j = .Cells(65536, 1).End(xlUp).Row + 1
　　　　　　End With
　　　　　　.Rows(j).Insert

　　　　　　'記入用のシートからコピーする列は、Resize(, 7)　は、7列という意味
　　　　　　kSh.Range("A13").Resize(, 7).Copy .Cells(j, 1)
　　　　Next c
　　　　.AutoFilterMode = False
　　　　'検索用のデータの削除
　　　　.Range("AZ1").CurrentRegion.ClearContents
　　End With
　　Application.ScreenUpdating = True
　　Set myData = Nothing
　　Set iSh = Nothing
　　Set kSh = Nothing
End Sub

回答No.2

Wendy02

こんにちは。

ご自身で考えられたのですね。私は、すぐに理解できませんでしたが、コードの書き方とかは別として、独特のアイデアで、それは非凡な発想だと思います。ここの掲示板では、そのコードで理解できる人ばかりではありませんが、そのコードなら、分かる人は、必ず評価してくれるはずです。やはり、最初にコードを書くべきだったと思います。

行を挿入して、そこに合計などを入れるのでしょうか。
今、別の方法を考えてみたのですが、パッと思いつきません。

通常は、以下のようになっていて、下にSelect を下げていく方法で、上と下の Cells(i,7).Value <>Cells(i+1,7).Value　[7は、G列] というような方法をとりますが、特に、何千行という場合には、それは、いわゆる、ぬるいコードというしかありません。かといって、なかなかSort を使おうという発想にはなりません。Sort を使う真価は、大量の行がある時です。3万行程度でも、まったく、待たされることがなく、選び出します。

ここの質問は、最初だと思いますが、もう数回、頑張ってみるつもりがあるなら、私もお付き合いいたします。あまり、くだらないことを書くつもりはありませんが、もう少し、テクニック的なものが必要ですね。

こんなスタイルになるのでしょうか？

部署
--------
営業1課
営業1課
営業1課
営業1課
営業1課
営業2課　<- 一行、挿入して、ペースト
営業2課
営業2課
営業2課

回答No.1

Wendy02

こんばんは。

例えば、こんな風に書きます。
なお、マクロのご質問では、なるべくコードを出したほうが回答が付きやすいです。
そうしないと、製作依頼のように思われて、敬遠されてしまいます。

Sub Test1()
　　Dim myCrite As String
　　myCrite = Range("F1").Value

　　If myCrite <> "" Then
　　　　Range("A1").CurrentRegion.AutoFilter _
　　　　Field:=1, _
　　　　Criteria1:=myCrite, _
　　　　Operator:=xlOr, _
　　　　Criteria2:="="
　　End If
End Sub

お礼

お礼遅くなって申し訳ございません。解決いたしました。
どうもありがとうございました。
質問は、記入用から一覧表の部署毎の一番下に挿入できるようにマクロを組みましたがまだマクロ初心者で部署毎にマクロを作ったので一つにしようと
"Criteria1:="後に関数とか入れてみましたがだめだったので質問しました。コードは長いので以下一部をだします。
Sub 記入()
Sheets("一覧表").Select
Columns("D:G").Select
Selection.AutoFilter
Selection.AutoFilter Field:=4, Criteria1:="営業"
Range("G1").Select
Range(Selection, Selection.End(xlDown)).Select
Dim x1 As Integer, y1 As Integer
Dim z1 As Long
y1 = Range("A:A").Column
z1 = Range("G1").End(xlDown).Row
With ActiveSheet
For x1 = 1 To y1
Range(Cells(z1 + 1, x1), Cells(z1 + 1, x1)).Select
Selection.EntireRow.Insert
Sheets("記入用").Select
Range("A13").Select
Selection.Copy
Sheets("一覧表").Select
ActiveCell.Select
Selection.PasteSpecial Paste:=xlValues
Next x1
End With
Dim x2 As Integer, y2 As Integer
Dim z2 As Long
y2 = Range("B:B").Column
z2 = Range("G1").End(xlDown).Row
With ActiveSheet
For x2 = 2 To y2
Range(Cells(z2 + 1, x2), Cells(z2 + 1, x2)).Select
Sheets("記入用").Select
Range("B13").Select
Selection.Copy
Sheets("一覧表").Select
ActiveCell.Select
ActiveSheet.Paste
Selection.Font.ColorIndex = 0
Next x2
End With