Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


38878 / 76732 ←次へ | 前へ→

【42981】Re:抽出結果を別シートに保存2
回答  ハチ  - 06/9/28(木) 15:40 -

引用なし
パスワード
   ▼トホホ さん:
列が移動します の条件はなくなったみたいですけど。
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

0 hits

【42976】抽出結果を別シートに保存2 トホホ 06/9/28(木) 13:39 質問
【42980】Re:抽出結果を別シートに保存2 Statis 06/9/28(木) 15:32 回答
【42981】Re:抽出結果を別シートに保存2 ハチ 06/9/28(木) 15:40 回答
【42982】Re:抽出結果を別シートに保存2 トホホ 06/9/28(木) 16:46 質問
【42983】Re:抽出結果を別シートに保存2 ハチ 06/9/28(木) 17:29 発言
【43092】Re:抽出結果を別シートに保存2 トホホ 06/10/2(月) 9:07 お礼
【42984】Re:抽出結果を別シートに保存2 Statis 06/9/28(木) 17:33 回答
【43093】Re:抽出結果を別シートに保存2 トホホ 06/10/2(月) 9:08 お礼

38878 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free