| |
先日こちらで抽出結果を別シートに保存するマクロを
教えていただきました。
それを自分で応用しようと思ったのですが、
なかなか上手くいかないのが実情です。
下の様な抽出条件にさらに抽出条件を追加したいのです。
＜現在の内容＞フィールド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
|
|
トホホ
- 06/9/28(木) 13:39 -
