Excel VBA質問箱 IV

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

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


54953 / 76732 ←次へ | 前へ→

【26562】Re:オートフィルター抽出結果を別シートへ
回答  ponpon  - 05/7/10(日) 9:33 -

引用なし
パスワード
   甘いスイカ さん、りんさん、MokoMokoさん
こんばんは。
似たようなことをしていたもんで
こんな感じではいかがでしょう。
違っていたらすみません。

Sub test()
  Dim mySH1 As Worksheet
  Dim mySH As Worksheet
  Dim myR  As Range
  Dim sh As Worksheet
  Dim myVal As Variant
  Dim i As Integer
  
  Application.ScreenUpdating = False

    ' 「シート1」以外のシートの削除
'  For Each sh In ThisWorkbook.Worksheets
'    If Not sh.Name = "シート1" Then
'     Application.DisplayAlerts = False
'     sh.Delete
'     Application.DisplayAlerts = True
'    End If
'  Next
  
  Set mySH1 = Worksheets("シート1")
  Set myR = mySH1.Range("A1").CurrentRegion
    myR.Columns(3).AdvancedFilter xlFilterCopy, _
            copytorange:=mySH1.Range("Z1"), unique:=True
    myVal = mySH1.Range("Z2", mySH1.Range("Z65536").End(xlUp)).Value
  
  For i = 1 To UBound(myVal, 1)
   Set mySH = Worksheets.Add(after:=Sheets(Sheets.Count))
     mySH.Name = myVal(i, 1) & "のデータ"
   With myR
     .AutoFilter field:=3, Criteria1:=myVal(i, 1)
     .Copy mySH.Range("A1")
     .AutoFilter
   End With
  Next i
  mySH1.Range("Z:Z").ClearContents
  Application.ScreenUpdating = True

End Sub
0 hits

【26542】オートフィルター抽出結果を別シートへ 甘いスイカ 05/7/8(金) 12:18 質問
【26546】Re:オートフィルター抽出結果を別シートへ りん 05/7/8(金) 13:05 発言
【26559】Re:オートフィルター抽出結果を別シートへ MokoMoko 05/7/9(土) 20:05 回答
【26562】Re:オートフィルター抽出結果を別シートへ ponpon 05/7/10(日) 9:33 回答
【26587】Re:オートフィルター抽出結果を別シートへ 甘いスイカ 05/7/11(月) 12:05 お礼

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