Excel VBA質問箱 IV

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

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


6794 / 13644 ツリー ←次へ | 前へ→

【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 お礼[未読]

【42976】抽出結果を別シートに保存2
質問  トホホ  - 06/9/28(木) 13:39 -

引用なし
パスワード
   先日こちらで抽出結果を別シートに保存するマクロを
教えていただきました。
それを自分で応用しようと思ったのですが、
なかなか上手くいかないのが実情です。
下の様な抽出条件にさらに抽出条件を追加したいのです。

<現在の内容>フィールド1(A列)を使用してA〜Fのキーでレコードを抽出する。
それぞれキー項目でシートに保存
  抽出 "りんご", 1
  抽出 "なし", 1
  抽出 "みかん", 1
  抽出 "ばなな", 1
  抽出 "メロン", 1
  抽出 "柿", 1
りんご、なし、みかん、ばなな、メロン、柿の6枚のシートが出来上がる。

<変更したい内容>フィールド2(B列)には原産地が入力されているので
りんごだけはさらに原産地ごとに抽出しその結果もシートに保存したい。
"りんご"、"なし"、"みかん"、"ばなな "、"メロン"、"柿"の6枚のシート
プラス"りんご・青森""りんご・山形""りんご・鳥取"というように9枚のシートが
出来上がるようにしたい。
複雑ですが、出来ますでしょうか?


Sub 2.抽結果別シートへ保存()
  抽出 "りんご", 1
  抽出 "なし", 1
  抽出 "みかん", 1
  抽出 "ばなな", 1
  抽出 "メロン", 1
  抽出 "柿", 1
End Sub
'分類=分類を文字列で指定。項目=列番号を数字で指定
Private Sub 抽出(ByVal SYOHINBU As String, ByVal 項目 As Integer)
  Dim Org_Sh As Worksheet '元Sheet
  Dim Des_Sh As Worksheet '先Sheet
  '元SheetをSet
  Set Org_Sh = Worksheets("RE_CALCU")
  '先SheetをSet なければ作成。
  On Error Resume Next
    Set Des_Sh = Worksheets(SYOHINBU)
  On Error GoTo 0
  If Des_Sh Is Nothing Then
    Set Des_Sh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    Des_Sh.Name = SYOHINBU
  Else
    Des_Sh.Cells.Clear
  End If
  'AutoFilterでコピー
  With Org_Sh.UsedRange
   .AutoFilter Field:=項目, Criteria1:=SYOHINBU
   .SpecialCells(xlVisible).Copy Des_Sh.Range("A1")
   .AutoFilter
  End With
 
  Set Org_Sh = Nothing
  Set Des_Sh = Nothing
End Sub

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

引用なし
パスワード
   こんにちは
りんごだけ別にしては
試していませんがお試しを。
(尚、抽出データが無い場合の対策処理は含みません)
すべて同じ標準モジュールにて

Dim Org_Sh As Worksheet '元Sheet
Sub 抽結果別シートへ保存()
  Dim Va As Variant
  '元SheetをSet
  Set Org_Sh = Worksheets("RE_CALCU")
  For Each Va In Array("りんご", "なし", "みかん", "ばなな", "メロン", "柿")
    If Va <> "りんご" Then
      抽出 Va, 1
    Else
      抽出1 Va
    End If
  Next Va
End Sub
'分類=分類を文字列で指定。項目=列番号を数字で指定
Private Sub 抽出(ByVal SYOHINBU As String, ByVal 項目 As Integer)
  
  Dim Des_Sh As Worksheet '先Sheet
  
  '先SheetをSet なければ作成。
  On Error Resume Next
    Set Des_Sh = Worksheets(SYOHINBU)
  On Error GoTo 0
  If Des_Sh Is Nothing Then
    Set Des_Sh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    Des_Sh.Name = SYOHINBU
  Else
    Des_Sh.Cells.Clear
  End If
  'AutoFilterでコピー
  With Org_Sh.UsedRange
     .AutoFilter Field:=項目, Criteria1:=SYOHINBU
     .SpecialCells(xlVisible).Copy Des_Sh.Range("A1")
     Org_Sh.AutoFilterMode = False
  End With
  
  Set Des_Sh = Nothing
End Sub

Private Sub 抽出1(ByVal SYOHINBU1 As String)
   Dim Des_Sh1 As Worksheet '先Sheet
   Dim Da As Variant
   '先SheetをSet なければ作成。
   For Each Da In Array("青森", "山形", "鳥取")
     On Error Resume Next
      Set Des_Sh1 = Worksheets(SYOHINBU1 & "・" & Da)
     On Error GoTo 0
     If Des_Sh1 Is Nothing Then
      Set Des_Sh1 = Worksheets.Add(After:=Worksheets(Worksheets.Count))
      Des_Sh1.Name = SYOHINBU1 & "・" & Da
     Else
      Des_Sh1.Cells.Clear
     End If
    'AutoFilterでコピー
    With Org_Sh.UsedRange
       .AutoFilter Field:=1, Criteria1:=SYOHINBU1
       .AutoFilter Field:=2, Criteria1:=Da
       .SpecialCells(xlVisible).Copy Des_Sh1.Range("A1")
       Org_Sh.AutoFilterMode = False
    End With
    Set Des_Sh1 = Nothing
   Next Da
End Sub

【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

【42982】Re:抽出結果を別シートに保存2
質問  トホホ  - 06/9/28(木) 16:46 -

引用なし
パスワード
   いつもありがとうございます。
私の説明が足りなくてすみませんm(__)m
もう一度ご説明させていただきますと、


これが今のマクロです。
  抽出 "りんご", 1
  抽出 "なし", 1
  抽出 "みかん", 1
  抽出 "ばなな", 1
  抽出 "メロン", 1
  抽出 "柿", 1
<結果>りんご、なし、みかん、ばなな、メロン、柿の6枚のシートが出来上がる。

完成イメージ
  抽出 "りんご", 1
  抽出 "りんご", 1, "青森", 2
  抽出 "りんご", 1, "鳥取", 2
  抽出 "りんご", 1, "山形", 2
  抽出 "なし", 1
  抽出 "みかん", 1
  抽出 "ばなな", 1
  抽出 "メロン", 1
  抽出 "柿", 1
<結果>りんご、青森、鳥取、山形、なし、みかん、ばなな、メロン、柿の9枚のシートが出来上がる。
また青森、鳥取、山形の3つのシートには第1条件である、
フィールド1(A列)を転記したくないのですが・・・。
今の例であれば"りんご"が表示されるているフィールド自体を抽出結果からなくしたいのですが
条件に使っているのに、抽出結果から、フィールド1(A列)を除くことは不可能でしょうか?

【42983】Re:抽出結果を別シートに保存2
発言  ハチ  - 06/9/28(木) 17:29 -

引用なし
パスワード
   ▼トホホ さん:
>いつもありがとうございます。
>私の説明が足りなくてすみませんm(__)m
>もう一度ご説明させていただきますと、
>
>
>これが今のマクロです。
>  抽出 "りんご", 1
>  抽出 "なし", 1
>  抽出 "みかん", 1
>  抽出 "ばなな", 1
>  抽出 "メロン", 1
>  抽出 "柿", 1
><結果>りんご、なし、みかん、ばなな、メロン、柿の6枚のシートが出来上がる。
>
>完成イメージ
>  抽出 "りんご", 1
>  抽出 "りんご", 1, "青森", 2
>  抽出 "りんご", 1, "鳥取", 2
>  抽出 "りんご", 1, "山形", 2
>  抽出 "なし", 1
>  抽出 "みかん", 1
>  抽出 "ばなな", 1
>  抽出 "メロン", 1
>  抽出 "柿", 1
><結果>りんご、青森、鳥取、山形、なし、みかん、ばなな、メロン、柿の9枚のシートが出来上がる。
>また青森、鳥取、山形の3つのシートには第1条件である、
>フィールド1(A列)を転記したくないのですが・・・。
>今の例であれば"りんご"が表示されるているフィールド自体を抽出結果からなくしたいのですが
>条件に使っているのに、抽出結果から、フィールド1(A列)を除くことは不可能でしょうか?

Sub抽出 の中に実装することは「可能か不可能か」と聞かれれば「可能」です。
ですが、かなり汎用性の低いコードになります。

A列がいらない こと以外にデータに不備がないなら
Sub抽出とは別に削除すれば良いと思いますけど。

抽出 "りんご", 1, "青森", 2
WorkSheets("りんご_青森").・・・ 'ここはちょっとやってみてください^^

【42984】Re:抽出結果を別シートに保存2
回答  Statis  - 06/9/28(木) 17:33 -

引用なし
パスワード
   こんにちは
これで如何かな

Dim Org_Sh As Worksheet '元Sheet
Sub 抽結果別シートへ保存()
  Dim Va As Variant
  '元SheetをSet
  Set Org_Sh = Worksheets("RE_CALCU")
  抽出 "りんご", 1
  For Each Va In Array("りんご", "なし", "みかん", "ばなな", "メロン", "柿")
    If Va <> "りんご" Then
      抽出 Va, 1
    Else
      抽出1 Va
    End If
  Next Va
End Sub
'分類=分類を文字列で指定。項目=列番号を数字で指定
Private Sub 抽出(ByVal SYOHINBU As String, ByVal 項目 As Integer)
 
  Dim Des_Sh As Worksheet '先Sheet
 
  '先SheetをSet なければ作成。
  On Error Resume Next
    Set Des_Sh = Worksheets(SYOHINBU)
  On Error GoTo 0
  If Des_Sh Is Nothing Then
    Set Des_Sh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    Des_Sh.Name = SYOHINBU
  Else
    Des_Sh.Cells.Clear
  End If
  'AutoFilterでコピー
  With Org_Sh.UsedRange
     .AutoFilter Field:=項目, Criteria1:=SYOHINBU
     .SpecialCells(xlVisible).Copy Des_Sh.Range("A1")
     Org_Sh.AutoFilterMode = False
  End With
 
  Set Des_Sh = Nothing
End Sub

Private Sub 抽出1(ByVal SYOHINBU1 As String)
   Dim Des_Sh1 As Worksheet '先Sheet
   Dim Da As Variant
   '先SheetをSet なければ作成。
   For Each Da In Array("青森", "山形", "鳥取")
     On Error Resume Next
      Set Des_Sh1 = Worksheets(SYOHINBU1 & "・" & Da)
     On Error GoTo 0
     If Des_Sh1 Is Nothing Then
      Set Des_Sh1 = Worksheets.Add(After:=Worksheets(Worksheets.Count))
      Des_Sh1.Name = SYOHINBU1 & "・" & Da
     Else
      Des_Sh1.Cells.Clear
     End If
    'AutoFilterでコピー
    With Org_Sh.UsedRange
       .AutoFilter Field:=1, Criteria1:=SYOHINBU1
       .AutoFilter Field:=2, Criteria1:=Da
       .SpecialCells(xlVisible).Copy Des_Sh1.Range("A1")
       Des_Sh1.Columns(1).Delete
       Org_Sh.AutoFilterMode = False
    End With
    Set Des_Sh1 = Nothing
   Next Da
End Sub

【43092】Re:抽出結果を別シートに保存2
お礼  トホホ  - 06/10/2(月) 9:07 -

引用なし
パスワード
   ありがとうございます。
おっしゃるとおり、フィールド削除を最後に付け足すのは
それほど、必要のないように感じました。
抽出→シート保存で終わりにしました。
早速使わせていただいております。
ありがとうございました。

【43093】Re:抽出結果を別シートに保存2
お礼  トホホ  - 06/10/2(月) 9:08 -

引用なし
パスワード
   ありがとうございました。
大変参考になりました。

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