質問です。

Q1305455789
の分でCSVデータのF列のデータを日付を限定して抽出したいのです。
F列
2011/5/17 14:16
2011/5/17 14:16
2011/5/17 14:16
2011/5/17 14:16
2011/5/17 14:16
2011/5/17 14:16
2011/5/17 14:16
2011/5/17 14:16
2011/5/18 21:06
2011/5/17 14:16
2011/5/19 8:12
2011/5/19 9:32
2011/5/17 14:16
2011/5/17 14:16

抽出条件
2011/5/1から2011/5/17まで

みたいに日付を限定できるようにマクロを修正できますか?
マクロの中で修正できても良いですが
よろしくお願いします。

回答の条件
  • 1人3回まで
  • 13歳以上
  • 登録:2011/05/21 14:16:03
  • 終了:2011/05/23 09:17:09

回答(1件)

質問者が未読の回答一覧

 回答者回答受取ベストアンサー回答時間
1 online_p 1153 848 59 2011-05-22 16:05:49
  • id:inosisi4141
    takntさん
    Q1305455789
    の分でCSVデータのF列のデータを日付を限定して抽出したいのです。
    F列
    2011/5/17 14:16
    2011/5/17 14:16
    2011/5/17 14:16
    2011/5/17 14:16
    2011/5/17 14:16
    2011/5/17 14:16
    2011/5/17 14:16
    2011/5/17 14:16
    2011/5/18 21:06
    2011/5/17 14:16
    2011/5/19 8:12
    2011/5/19 9:32
    2011/5/17 14:16
    2011/5/17 14:16

    抽出対象条件例として
    2011/5/1から2011/5/17まで

    マクロ実行前に入力し
    抽出条件に該当するデータから集計し
    それ以外は表示対象にしない。

    みたいに日付を限定できるようにマクロを修正できますか?
    マクロの中で修正できても良いですが
    よろしくお願いします。
  • id:taknt
    やるとしたら月曜日あたりですね。

  • id:inosisi4141
    ありがとうございます。
    了解です。
    よろしくお願いします。
  • id:inosisi4141
    takntさん
    この質問内容は再検討しますので一旦取り消します。
  • id:taknt
    なーんだ。

    とりあえず 作ったやつ 貼っておきます。

    Sub main()
    Dim p As String
    Dim 抽出条件開始 As String
    Dim 抽出条件終了 As String
    '対象フォルダを指定してください。
    'このフォルダに この実行用のブックは 入れないでください。

    p = "C:\test\"

    '2011/5/1から2011/5/17まで (終了日も含みます)
    抽出条件開始 = "2011/5/1"
    抽出条件終了 = "2011/5/17"


    '処理対象となる拡張子を指定して 呼び出します。
    Call jikkou(p, "csv", 抽出条件開始, 抽出条件終了)

    End Sub


    Sub jikkou(p As String, s As String, st As String, se As String)

    Dim bk As Workbook
    Dim b1 As String

    Application.DisplayAlerts = False
    cks = Convert_Date(st)
    cke = Convert_Date(se)
    f = Dir(p & "*." & s, vbNormal)

    Do While f <> ""
    Set w = Workbooks.Open(Filename:=p & f, UpdateLinks:=False, ReadOnly:=True)
    '処理対象は 1番目のシートのみ。

    With w.Sheets(1)

    kg = 2 '開始する行

    ck = "B" 'チェックする列

    For b = kg To .Cells(kg, ck).End(xlDown).Row

    '日付が条件にあうかチェックする

    ckd = "G" '日付は G列
    b1 = .Cells(b, ckd)
    ckk = Convert_Date(b1)
    If cks <= ckk And ckk <= cke Then
    Set trow = ThisWorkbook.Sheets(1).Range("A:A").Find(What:=.Cells(b, ck), LookIn:=xlValues)
    If trow Is Nothing Then
    '存在しない場合
    If ThisWorkbook.Sheets(1).Cells(2, "A") = "" Then
    r = 2
    Else
    If ThisWorkbook.Sheets(1).Cells(3, "A") = "" Then
    r = 3
    Else
    r = ThisWorkbook.Sheets(1).Cells(2, "A").End(xlDown).Row + 1
    End If
    End If

    ThisWorkbook.Sheets(1).Cells(r, "B") = 0
    ThisWorkbook.Sheets(1).Cells(r, "C") = 0
    ThisWorkbook.Sheets(1).Cells(r, "D") = 0
    ThisWorkbook.Sheets(1).Cells(r, "E") = 0
    ThisWorkbook.Sheets(1).Cells(r, "F") = 0

    Else
    '存在する場合
    r = trow.Row
    End If

    ThisWorkbook.Sheets(1).Cells(r, "A") = .Cells(b, ck)

    c = .Cells(b, "H")
    If c <> "" Then
    c2 = ThisWorkbook.Sheets(1).Cells(r, "B")
    If c2 = "" Then
    c2 = 1
    Else
    c2 = c2 + 1
    End If
    ThisWorkbook.Sheets(1).Cells(r, "B") = c2
    End If


    c = .Cells(b, "I")
    If c = "0" Then
    c2 = ThisWorkbook.Sheets(1).Cells(r, "C")
    If c2 = "" Then
    c2 = 1
    Else
    c2 = c2 + 1
    End If
    ThisWorkbook.Sheets(1).Cells(r, "C") = c2
    End If

    c = .Cells(b, "J")
    If c <> "" Then
    c2 = ThisWorkbook.Sheets(1).Cells(r, "D")
    If c2 = "" Then
    c2 = 1
    Else
    c2 = c2 + 1
    End If
    ThisWorkbook.Sheets(1).Cells(r, "D") = c2
    End If

    c = .Cells(b, "G")
    If (c <> "") Then
    If Not (c = "0000-00-00 00:00:00" Or c = 0) Then
    c2 = ThisWorkbook.Sheets(1).Cells(r, "E")
    If c2 = "" Then
    c2 = 1
    Else
    c2 = c2 + 1
    End If
    ThisWorkbook.Sheets(1).Cells(r, "E") = c2
    End If
    End If

    ThisWorkbook.Sheets(1).Cells(r, "F") = Left(f, Len(f) - 4)
    End If
    Next b

    End With

    w.Close

    'シート2にシート1の内容を移動させる
    If ThisWorkbook.Sheets(1).Cells(3, "A") = "" Then
    r = 2
    Else
    r = ThisWorkbook.Sheets(1).Cells(2, "A").End(xlDown).Row + 1
    End If

    If ThisWorkbook.Sheets(2).Cells(3, "A") = "" Then
    r2 = 2
    Else
    r2 = ThisWorkbook.Sheets(2).Cells(2, "A").End(xlDown).Row + 1
    End If

    If ThisWorkbook.Sheets(2).Cells(2, "A") = "" Then r2 = 2

    ThisWorkbook.Sheets(1).Rows(2 & ":" & r).Cut Destination:=ThisWorkbook.Sheets(2).Cells(r2, "A")

    f = Dir
    Loop

    Application.DisplayAlerts = True

    End Sub

    Function Convert_Date(a As String) As Date
    Convert_Date = 0
    b = InStr(1, a, "/")
    '日付の区切りが / でなければ 日付とみなさない。
    If b = 0 Then Exit Function

    '年?
    If b = 5 Then
    c = Left(a, 4)
    b = InStr(6, a, "/")
    c2 = Mid(a, 6, b - 6)
    b2 = InStr(b + 1, a, " ")
    If b2 > 0 Then
    c3 = Mid(a, b + 1, b2 - b - 1)
    Else
    c3 = Right(a, Len(a) - b)
    End If
    Else
    c2 = Left(a, b - 1)
    b1 = InStr(b + 1, a, "/")
    c3 = Mid(a, b + 1, b1 - 3)
    b2 = InStr(b1 + 1, a, " ")
    If b2 > 0 Then
    c = Mid(a, b1 + 1, b2 - b1 - 1)
    Else
    c = Right(a, Len(a) - b1)
    End If
    End If
    Convert_Date = DateSerial(c, c2, c3)
    End Function
  • id:inosisi4141
    takntさん
    ありがとうございます。
    訳ありですみません。
    評価検討して連絡しますのでお待ちください。
  • id:inosisi4141
    takntさん
    検証してみたのですが
    最初に日付を絞り込む列はF列なんですが
    どうもG列をみにいっているみたいです。
    よろしくお願いします。
    連絡あれば質問立ち上げます。


    '2011/5/1から2011/5/17まで (終了日も含みます)
    抽出条件開始 = "2011/5/1"
    抽出条件終了 = "2011/5/17"

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません