Excel VBA質問箱 IV

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

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


51675 / 76732 ←次へ | 前へ→

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

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