| |
▼トホホ さん：
列が移動します の条件はなくなったみたいですけど。
Optionalで指定できるようにしました。
ついでに同一列の別条件 りんご&みかん も出せるように。
Option Explicit
Sub main()
抽出 "りんご", 1
抽出 "みかん", 1
抽出 "りんご", 1, "青森", 2
抽出 "りんご", 1, "みかん", 1
End Sub
'分類=分類を文字列で指定。項目=列番号を数字で指定
Private Sub 抽出(ByVal 条件 As String, ByVal 項目 As Integer, _
Optional ByVal 条件2 As String, Optional ByVal 項目2 As Integer)
Dim Org_Sh As Worksheet '元Sheet
Dim Des_Sh As Worksheet '先Sheet
Dim ErFg As Boolean '引数のエラーフラグ
Dim ShName As String 'Sheetの名前 追加。
'引数のエラー判定
ErFg = False
Select Case True
Case 項目 = 0: ErFg = True
Case 条件2 <> "" And 項目2 = 0: ErFg = True
Case 条件2 = "" And 項目2 <> 0: ErFg = True
End Select
If ErFg = True Then
MsgBox "引数が正しくありません" & vbCr _
& 条件 & "," & 項目 & "," & 条件2 & "," & 項目2
Exit Sub
End If
'元SheetをSet
Set Org_Sh = Worksheets("RE_CALCU")
'先SheetをSet なければ作成。条件2の引数判定を追加
If 条件2 <> "" Then
ShName = 条件 & "_" & 条件2
Else
ShName = 条件
End If
On Error Resume Next
Set Des_Sh = Worksheets(ShName)
On Error GoTo 0
If Des_Sh Is Nothing Then
Set Des_Sh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
Des_Sh.Name = ShName
Else
Des_Sh.Cells.Clear
End If
'AutoFilterでコピー 第2条件がある場合の動作を追加
With Org_Sh.UsedRange
'第2引数がない場合、項目列が違う場合
If 項目 <> 項目2 Then
.AutoFilter Field:=項目, Criteria1:=条件
If 条件2 <> "" And 項目2 <> 0 Then
.AutoFilter Field:=項目2, Criteria1:=条件2
End If
End If
'第2引数ありで項目列が同じ場合。Or条件で抽出
If 項目 = 項目2 Then
.AutoFilter Field:=項目, Criteria1:=条件, Operator:=xlOr, Criteria2:=条件2
End If
.SpecialCells(xlVisible).Copy Des_Sh.Range("A1")
.AutoFilter
End With
Set Org_Sh = Nothing
Set Des_Sh = Nothing
End Sub
|
|
ハチ
- 06/9/28(木) 15:40 -
