| |
こんにちは
りんごだけ別にしては
試していませんがお試しを。
（尚、抽出データが無い場合の対策処理は含みません）
すべて同じ標準モジュールにて
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
|
|
Statis
- 06/9/28(木) 15:32 -
