Excel VBA質問箱 IV

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

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


38881 / 76738 ←次へ | 前へ→

【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
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 お礼

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