Excel VBA質問箱 IV

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

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


51689 / 76732 ←次へ | 前へ→

【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

0 hits

【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 回答

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