Excel VBA質問箱 IV

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

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


8981 / 13646 ツリー ←次へ | 前へ→

【29897】オートフィルタ ハッチ 05/10/15(土) 21:06 質問[未読]
【29899】Re:オートフィルタ ponpon 05/10/15(土) 21:32 発言[未読]
【29901】Re:オートフィルタ とまと 05/10/15(土) 23:32 発言[未読]
【29902】Re:オートフィルタ とまと 05/10/15(土) 23:33 発言[未読]
【29903】Re:オートフィルタ ponpon 05/10/16(日) 0:12 発言[未読]
【29905】Re:オートフィルタ Hirofumi 05/10/16(日) 0:30 回答[未読]
【29906】Re:オートフィルタ とまと 05/10/16(日) 0:38 発言[未読]
【29907】Re:オートフィルタ Hirofumi 05/10/16(日) 9:46 回答[未読]
【29910】Re:オートフィルタ yasu 05/10/16(日) 10:50 発言[未読]
【29916】Re:オートフィルタ ハッチ 05/10/16(日) 14:12 質問[未読]
【29919】Re:オートフィルタ Hirofumi 05/10/16(日) 15:05 回答[未読]
【29997】Re:オートフィルタ ハッチ 05/10/17(月) 21:14 お礼[未読]
【29928】Re:オートフィルタ とまと 05/10/16(日) 18:22 発言[未読]
【29929】Re:オートフィルタ kobasan 05/10/16(日) 18:56 発言[未読]
【29931】Re:オートフィルタ とまと 05/10/16(日) 20:58 回答[未読]

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

引用なし
パスワード
   こんばんわ。
すみませんが、教えてください。

オートフィルタで抽出したデータを他のブックに貼り付けるマクロを考えています。抽出条件は指定期間(例2005/7/1〜2005/7/31)にあうものです。

 名前  国語  数学  社会  理科
 A    7/1   7/6   7/1   7/3
 B    7/3  6/30   7/5  
 C         7/2  6/30   7/1
 D    7/5   7/2   7/3   7/1
 E          6/27   7/1   7/5
 
国語(B列)の指定期間を抽出して貼り付けるマクロはできたのですが、国語で空白セルのところがあった時に、空白セルの行のみ次の数学(C列)にうつって指定期間の抽出、また条件にあわなければ次の列へ・・・という動きをし、結果を他のブックに貼り付けたいのですがどの様に作ればいいのかで悩んでいます。

今の状態です。
Workbooks.Open Filename:=元データ
  Sheets(wsn).Select
  Range("A1").Select
  Selection.AutoFilter
  Selection.AutoFilter Field:=2, Criteria1:=開始年月日, Operator:=xlAnd, _
    Criteria2:=終了年月日
  Selection.CurrentRegion.Select
  Selection.Copy

これをどう変えたらいいのか、教えていただきたいです。

宜しくお願いします。

【29899】Re:オートフィルタ
発言  ponpon  - 05/10/15(土) 21:32 -

引用なし
パスワード
   こんばんは。

直接の回答でなくて申し訳ありませんが・・・

オートフィルターでは、期間の空白は拾いませんので難しいと思います。
サンプルは、そもそも日付でソートされてないようですが、
その空白(国語の)が、期間内かどうかをどのように判定するのでしょうか?

私には、できないかもしれませんが、
たとえば、サンプルで、7/1から7/4を抽出するとして、貼り付けた先のシートは、
どのような結果になるのでしょうか?
私だけかもしれませんが、今ひとつやりたいことが分かりません。

【29901】Re:オートフィルタ
発言  とまと  - 05/10/15(土) 23:32 -

引用なし
パスワード
   こんばんは。

オートフィルタを直接その列でかけるのではなくて
作業列をつくってその作業列にたいして実行すれば
できるのではないかと思います。
数式で国語の列が空白なら数学の列
数学が空白なら社会の列という具合の数式を埋め込みます。
以下サンプルです。

Sub test()

With Sheets(wsn)
 .Columns("F").Clear
 rowA = .UsedRange.Rows.Count
  With .Range("F2:F" & rowA)
   .Formula = "=IF(B2<>"""",B2,IF(C2<>"""",C2,IF(D2<>"""",D2,E2)))"
   .Value = .Value
   .NumberFormatLocal = Range("B2").NumberFormatLocal
  End With
End With


End Sub

【29902】Re:オートフィルタ
発言  とまと  - 05/10/15(土) 23:33 -

引用なし
パスワード
   F列は空白ですよね?
削除するのでテストシートで試してみてください。

【29903】Re:オートフィルタ
発言  ponpon  - 05/10/16(日) 0:12 -

引用なし
パスワード
   こんばんは。

なるほどね。やっと意味がわかりました。
こうやって質問を読み返すと、ちゃんと伝わります。
自分の国語力のなさがよくわかります。

【29905】Re:オートフィルタ
回答  Hirofumi  - 05/10/16(日) 0:30 -

引用なし
パスワード
   私は、やはり望むのがどの様な結果なのか今一解りませんので
「期間内のデータを別のシートに抽出する」と解釈して以下の様にして見ました
ピントがずれて居たらゴメンナサイ
尚、オートフィルタは使用していません

Option Explicit

Public Sub Sample()

  'データの列数
  Const clngColumns As Long = 5
  
  Dim i As Long
  Dim j As Long
  Dim lngRows As Long
  Dim lngRow As Long
  Dim rngList As Range
  Dim vntData As Variant
  Dim wkbResult As Workbook
  Dim rngResult As Range
  Dim vntStart As Variant
  Dim vntFInish As Variant
  Dim blnOutPut As Boolean
  Dim strProm As String
  
  'Listの左上隅セル位置を基準として設定(列見出しの最左セル位置)
  Set rngList = ActiveSheet.Cells(1, "A")
  With rngList
    'データ行数を取得
    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
    'データが無い場合
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
  End With
  
  '開始年月日入力
  If Not GetDate(vntStart, "開始年月日入力", _
        DateSerial(Year(Date), Month(Date), 1)) Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If
  
  '開始年月日入力
  If Not GetDate(vntFInish, "終了年月日入力", _
        DateSerial(Year(Date), Month(Date) + 1, 0)) Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If
  
  '画面更新を停止
'  Application.ScreenUpdating = False
  
  '新規Bookを追加
  Set wkbResult = Workbooks.Add
  '結果を書き込むセル位置を設定
  Set rngResult = wkbResult.Worksheets(1).Cells(1, "A")
  
  '結果用シートに列見出しを出力
  rngResult.Resize(, clngColumns).Value _
          = rngList.Resize(, clngColumns).Value
  '出力行位置の初期値設定
  lngRow = 1
  'データ行数全てに就いて繰り返し
  For i = 1 To lngRows
    'データを配列に取得
    vntData = rngList.Offset(i).Resize(lngRows, clngColumns).Value
    '出力フラグをFalseに
    blnOutPut = False
    'データの比較
    For j = 2 To clngColumns
      'データが日付範囲に無い場合
      If vntData(1, j) < vntStart Or vntFInish < vntData(1, j) Then
        '配列位置をクリア
        vntData(1, j) = Empty
      Else
        '出力フラグをTrueに
        blnOutPut = True
      End If
    Next j
    '出力フラグがTrueなら(出力指定なら)
    If blnOutPut Then
      '出力基準位置に就いて
      With rngResult
        'セルの書式設定
        .Offset(lngRow, 2).Resize(, clngColumns - 1).NumberFormat = "m/d"
        'データを出力
        .Offset(lngRow).Resize(, clngColumns).Value = vntData
      End With
      '出力行位置を更新
      lngRow = lngRow + 1
    End If
  Next i
  
  strProm = "処理が完了しました"
  
Wayout:
  
  '画面更新を再開
'  Application.ScreenUpdating = True
  
  Set rngList = Nothing
  Set rngResult = Nothing
  Set wkbResult = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

Private Function GetDate(vntDate As Variant, _
            strTitle As String, _
            vntDefault As Variant) As Boolean

'  年月日入力

  Dim strPrompt As String
  
  strPrompt = "月日を" & Format(vntDefault, "yyyy/m/d") & "の形で入力して下さい"
  Do
    vntDate = InputBox(strPrompt, strTitle, Format(vntDefault, "yyyy/m/d"))
    If IsDate(vntDate) Then
      vntDate = DateValue(vntDate)
      GetDate = True
      Exit Do
    Else
      If vntDate = "" Then
        Exit Do
      Else
        Beep
        strPrompt = strPrompt & "!"
      End If
    End If
  Loop

End Function

【29906】Re:オートフィルタ
発言  とまと  - 05/10/16(日) 0:38 -

引用なし
パスワード
   訂正です。

.NumberFormatLocal = Range("B2").NumberFormatLocal
   ↓
.NumberFormatLocal = .Range("B2").NumberFormatLocal


なにを望んでいらっしゃるかは想像ですね。
実行前と実行後の表なんかあるとわかりやすいんですけどね。。

【29907】Re:オートフィルタ
回答  Hirofumi  - 05/10/16(日) 9:46 -

引用なし
パスワード
   セル書式の設定位置が狂っていましたので修正して下さい

        'セルの書式設定
'        .Offset(lngRow, 2).Resize(, clngColumns - 1).NumberFormat = "m/d"
        .Offset(lngRow, 1).Resize(, clngColumns - 1).NumberFormat = "m/d" '★変更

【29910】Re:オートフィルタ
発言  yasu  - 05/10/16(日) 10:50 -

引用なし
パスワード
   ハッチさん

何か意味の取り違えが・・・出ているようですね。
現状のデータから→どのような仕上げにするのか?サンプルを明示されては
如何でしょう?

とまとさんや Hirofumi さんの解答が分かれるのも、やはり憶測がかなり
加味されているように思えます。
「対象外の月を外すという意味ですか・・・?」「そして新規ブックに貼り付け
ということでしょうか」

再度ご質問をされては如何でしょう?

【29916】Re:オートフィルタ
質問  ハッチ  - 05/10/16(日) 14:12 -

引用なし
パスワード
   ▼ponpon さん:
▼とまと さん:
▼Hirofumi さん:
▼yasu さん:

こんにちわ。色々なアドバイスありがとうございます。
こちらのご説明不足で申し訳ありませんm(__)m

詳しくご説明させていただきますと、下記のデータから
 名前  国語  数学  社会  理科
 A    7/1   7/6   7/1   7/3
 B    7/3  6/30   7/5  
 C         7/2  6/30   7/1
 D    7/5   7/2   7/3   7/1
 E          6/27   7/1   7/5
 F        6/25  6/30  6/29
     
     ↓  ↓  ↓  この様な結果を望んでいます。
名前  国語  数学  社会  理科
 A    7/1   7/6   7/1   7/3
 B    7/3  6/30   7/5  
 C         7/2  6/30   7/1
 D    7/5   7/2   7/3   7/1
 E          6/27   7/1   7/5

7/1〜7/31の条件に国語・数学・社会・理科のどれか一つでもあてはまるものの
名前の行を抽出したいと考えています。

ご迷惑おかけして申し訳ありませんが、お力添え宜しくお願いします。

【29919】Re:オートフィルタ
回答  Hirofumi  - 05/10/16(日) 15:05 -

引用なし
パスワード
   前の物と基本的には、同じ物です
違いは、前回の物は、範囲外の日付を消して居たものを
消さない様にした事と、速度を上げる為、結果を配列で一遍に出力して居る事です

尚、書き忘れた事ですが、日付はシリアル値で入って居る事が必須です

Option Explicit

Public Sub Sample2()

  'データの列数
  Const clngColumns As Long = 5
  
  Dim i As Long
  Dim j As Long
  Dim lngRows As Long
  Dim lngRow As Long
  Dim rngList As Range
  Dim vntData As Variant
  Dim wkbResult As Workbook
  Dim rngResult As Range
  Dim vntStart As Variant
  Dim vntFInish As Variant
  Dim blnOutPut As Boolean
  Dim strProm As String
  
  '開始年月日入力
  If Not GetDate(vntStart, "開始年月日入力", _
        DateSerial(Year(Date), Month(Date), 1)) Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If
  
  '開始年月日入力
  If Not GetDate(vntFInish, "終了年月日入力", _
        DateSerial(Year(vntStart), Month(vntStart) + 1, 0)) Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If
  
  'Listの左上隅セル位置を基準として設定(列見出しの最左セル位置)
  Set rngList = ActiveSheet.Cells(1, "A")
  With rngList
    'データ行数を取得
    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
    'データが無い場合
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'データを配列に取得(列見出しを含め)
    lngRows = lngRows + 1
    vntData = .Resize(lngRows, clngColumns).Value
  End With
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  '新規Bookを追加
  Set wkbResult = Workbooks.Add
  '結果を書き込むセル位置を設定
  Set rngResult = wkbResult.Worksheets(1).Cells(1, "A")
  
  '出力行位置の初期値設定
  lngRow = 2
  'データ行数全てに就いて繰り返し
  For i = 2 To lngRows
    '出力フラグをFalseに
    blnOutPut = False
    'データの比較
    For j = 2 To clngColumns
      'データが日付範囲に有る場合
      If vntStart <= vntData(i, j) _
            And vntData(i, j) <= vntFInish Then
        '出力フラグをTrueに
        blnOutPut = True
        '比較行データを書き込み行に転記
        vntData(lngRow, j) = vntData(i, j)
      End If
    Next j
    '出力フラグがTrueなら(出力指定なら)
    If blnOutPut Then
      '名前データを転記
      vntData(lngRow, 1) = vntData(i, 1)
      '出力行位置を更新
      lngRow = lngRow + 1
    End If
  Next i
  
  '出力基準位置に就いて
  With rngResult
    'セルの書式設定
    .Offset(1, 1).Resize(lngRow - 2, clngColumns - 1).NumberFormat = "m/d"
    'データを出力
    .Resize(lngRow - 1, clngColumns).Value = vntData
  End With
  
  strProm = "処理が完了しました"
  
Wayout:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
  Set rngResult = Nothing
  Set wkbResult = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

Private Function GetDate(vntDate As Variant, _
            strTitle As String, _
            vntDefault As Variant) As Boolean

'  年月日入力

  Dim strPrompt As String
  
  strPrompt = "月日を" & Format(vntDefault, "yyyy/m/d") & "の形で入力して下さい"
  Do
    vntDate = InputBox(strPrompt, strTitle, Format(vntDefault, "yyyy/m/d"))
    If IsDate(vntDate) Then
      vntDate = DateValue(vntDate)
      GetDate = True
      Exit Do
    Else
      If vntDate = "" Then
        Exit Do
      Else
        Beep
        strPrompt = strPrompt & "!"
      End If
    End If
  Loop

End Function

【29928】Re:オートフィルタ
発言  とまと  - 05/10/16(日) 18:22 -

引用なし
パスワード
   どれか一つの列でもという意味なんですね。
よい関数式があれば最初のでもいいんですけど、
浮かばなかったので、2列目から5列目まで
オートフィルタをループして条件をみたした
行のF列に1を書き込んでいます。
オートフィルタで日付を抽出するときは、書式が
あってないとエラーになるようなので
開始日と終了日の書式を変更しています。

Sub test2()

With Sheets(wsn)
 開始年月日 = Format(DateSerial(2005, 7, 1), .Range("B2").NumberFormatLocal)
 終了年月日 = Format(DateSerial(2005, 8, 1 - 1), .Range("B2").NumberFormatLocal)
 .Columns("F").Clear
  rowA = .Range("A1").CurrentRegion.Rows.Count
 For i = 2 To 5
   .AutoFilterMode = False
   Range("A1:F" & rowA).AutoFilter i, ">=" & 開始年月日, xlAnd, "<=" & 終了年月日
   Sheets(wsn).AutoFilter.Range.Columns(6).Value = 1
 Next i
 .AutoFilterMode = False
 .Range("F1").Value = "作業列"
End With

End Sub

【29929】Re:オートフィルタ
発言  kobasan  - 05/10/16(日) 18:56 -

引用なし
パスワード
   みなさん今晩は。

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

Sheet1 が元データ
Sheet1 のA列からE列のセルは、書式を文字列に設定してください。
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
  '
  '2行目から結果を貼り付け
  With Application
    Sheets("Sheet2").Range("A2").Resize(行数, 列数).Value _
      = .Transpose(.Transpose(d))
  End With
  '
  Set Dic = Nothing
End Sub

【29931】Re:オートフィルタ
回答  とまと  - 05/10/16(日) 20:58 -

引用なし
パスワード
   みなさん最後まで作成されてるようなので
わたしも(^^
★★★.xlsのsheet2に貼り付けています。
適宜変更してみてください。

Sub test3()

Dim i As Long
Dim st As String
Dim sh2 As Worksheet
Set sh2 = Workbooks("★★★.xls").Worksheets("sheet2") '適宜変更
sh2.Cells.Clear


Application.ScreenUpdating = False
  With Sheets(wsn)
   st = .Range("B2").NumberFormatLocal
   開始年月日 = Format(DateSerial(2005, 7, 1), st)
   終了年月日 = Format(DateSerial(2005, 8, 1 - 1), st)
   .Columns("F").Clear
    rowA = .Range("A1").CurrentRegion.Rows.Count
   For i = 2 To 5
     .AutoFilterMode = False
     .Range("A1:F" & rowA).AutoFilter i, ">=" & 開始年月日, xlAnd, "<=" & 終了年月日
     .AutoFilter.Range.Columns(6).Value = 1
   Next i
   .AutoFilterMode = False
   .Range("F1").Value = "作業列"
   .Range("A1").AutoFilter 6, 1
   .Range("A1").CurrentRegion.Copy sh2.Range("a1")
   .AutoFilterMode = False
   .Columns(6).Clear
    sh2.Columns(6).Clear
  End With
Application.ScreenUpdating = True

End Sub

【29997】Re:オートフィルタ
お礼  ハッチ  - 05/10/17(月) 21:14 -

引用なし
パスワード
   ▼Hirofumi さん:
▼kobasan さん:
▼とまと さん:

こんばんわ。教えてくださってありがとうございます!

今から全部試していきたいと思います。
まだ初心者なので、皆さんのマクロの意味を理解するところから
はじめていきますf(^-^;)
ちょっと時間がかかりそうです。。。

また、疑問な点がでてきましたらアドバイス宜しくお願いします。
ありがとうございました!

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