Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

15085 / 76738

←次へ　｜　前へ→


	【67136】Re:データの条件付コピー

kanabun - 10/11/8(月) 9:20 -


	引用なし

	パスワード

▼ベニーさん：

少し修正しました

Sub Try2()
　Dim WS2 As Worksheet
　Dim rr As Range, aList As Range, c As Range
　Dim n As Long, nSheet As Long
　
　With Worksheets("Sheet1")　 'A列の一意な番号リストを作成(範囲aList)
　　Set rr = .Range("A1").CurrentRegion
　　rr.Columns(1).AdvancedFilter xlFilterCopy, , .Range("BB1"), True
　　Set aList = .Range("BB1").CurrentRegion
　End With
　
　For nSheet = 2 To aList.Count
　　n = Worksheets.Count
　　If nSheet > n Then　　　　　　　　'シートがないとき
　　　　Set WS2 = Worksheets.Add(After:=Worksheets(n))
　　Else
　　　　Set WS2 = Worksheets(nSheet)　'シートがあるとき
　　　　WS2.UsedRange.ClearContents
　　End If　　　　　　　　　　　　　　'抽出Copy
　　rr.AdvancedFilter xlFilterCopy, aList.Resize(2), WS2.Range("A1")
　　WS2.Name = aList.Item(2).Value　　'抽出した番号をSheet名に
　　WS2.Columns.AutoFit　　　　　　　 '列幅AutoFit
　　aList.Item(nSheet + 1).Copy aList.Item(2)
　　Set WS2 = Nothing
　Next
　aList.Clear
End Sub

0 hits

▼

【67126】データの条件付コピー ベニー 10/11/7(日) 14:36