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