Excel VBA質問箱 IV

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

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


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

51666 / 76732

←次へ　｜　前へ→


	【29929】Re:オートフィルタ

kobasan - 05/10/16(日) 18:56 -


	引用なし

	パスワード

みなさん今晩は。

私も、ちょっと作ってみたので、のせてみます。
試してみてください。

Sheet1　が元データ
Sheet1 のＡ列からＥ列のセルは、書式を文字列に設定してください。
Sheet1 のG2 H2 セルも、書式を文字列に設定してください。
Sheet1 のG2 H2 セルに開始日、最終日を入れてください。

Sheet2 に結果を出力します。

Sub test()
Dim mday As Integer
Dim strng As String
Dim Dic As Object
Dim d()
Dim 行数 As Long, j As Long
Dim r As Range, c As Range
Dim 開始日, 最終日
Const 列数 = 5　　　' <--- 取得列数

　　'期間入力
　　開始日 = Split(Range("G2").Text, "/")　 'G2セル開始日
　　最終日 = Split(Range("H2").Text, "/")　 'H2セル最終日
　　
　　'Dictionaryを作成
　　Set Dic = CreateObject("Scripting.Dictionary")
　　For mday = 1 To 最終日(1)
　　　　strng = 開始日(0) & "/" & mday
　　　　Dic(strng) = Empty
　　Next
　　'
　　'抽出処理
　　For Each r In Range("A1", Range("A65536").End(xlUp))
　　For Each c In r.Resize(1, 列数)
　　　　If Dic.Exists(c.Text) = True Then
　　　　　　行数 = 行数 + 1
　　　　　　ReDim Preserve d(1 To 行数)
　　　　　　d(行数) = r.Resize(1, 列数).Value
　　　　　　Exit For
　　　　End If
　　Next
　　Next
　　'
　　'Sheet2を準備
　　'書式を文字列に設定
　　Sheets("Sheet2").Range("A:E").Resize(, 列数).NumberFormatLocal = "@"
　　Sheets("Sheet2").Cells.ClearContents
　　'1行目をコピー貼り付け
　　Sheets("Sheet2").Range("A1:E1").Value _
　　　　　　= Sheets("Sheet1").Range("A1:E1").Value
　　'
　　'２行目から結果を貼り付け
　　With Application
　　　　Sheets("Sheet2").Range("A2").Resize(行数, 列数).Value _
　　　　　　= .Transpose(.Transpose(d))
　　End With
　　'
　　Set Dic = Nothing
End Sub

1 hits

▼

【29897】オートフィルタ ハッチ 05/10/15(土) 21:06