FC2ブログ

スポンサーサイト 


上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

Excel VBA をやってみた その16 


過去記事に 大量なデータはどうする やら Excel VBA をやってみた その6 があったと思います。
要は、CSV ファイルを対象に ADO 接続して、SQL で必要なものを抽出しようというもの・・・
(Excelシートを対象に・・・Excel VBA をやってみた その7 があったり・・・)

今回の対象CSVのフォーマットは以下の様な感じで・・・・
ID,日時(yyyy/m/d h:mm),備考1,備考2
0001,2015/03/25 10:25,AAAA,BBBB
0001,2015/03/25 12:01,CCCC,DDDD
0001,2015/03/25 17:30,EE,FFF
0002,2015/03/26 9:15,KK,LL
0002,2015/03/26 12:10,MMMM,NNN
0002,2015/03/26 14:54,OOOOO,PPP
0002,2015/03/26 22:01,QQ,RRRR
・・・

この中から、同一IDで、同一日の最小/最大部分のみを抽出
0001,2015/03/25 10:25,AAAA,BBBB
0001,2015/03/25 17:30,EE,FFF
0002,2015/03/26 9:15,KK,LL
0002,2015/03/26 22:01,QQ,RRRR
・・・

で、この結果を
・ID毎のBook もしくは ID毎のシートに・・・・

実現の仕方には色々あると思います。
・ExcelにCSVファイルを展開して Filter 等の操作しながら結果を求める
・Access に1度データを取り込んで結果を吐き出す
・今記事の様に、CSV自体はExcel展開せずに最終形のExcel環境で操作できるようにする

考える際、1番いやだったのが
・項目名部分に「日時(yyyy/m/d h:mm)」というものが存在する
・ID部分を文字列として扱いたい

そこで、冒頭での記事では使わなかった「schema.ini」を利用する事に・・・
CSVファイルと同じフォルダ内の「schema.ini」に以下の様に記述しておくと
[CSVファイル名]
ColNameHeader=True
CharacterSet=932
Format=CSVDelimited
Col1=ID Char Width 255
Col2=日時 Date
Col3=備考1 Char Width 255
Col4=備考2 Char Width 255

CSVファイル内の項目名部分を置換えつつ、データの型を指定する事が出来ます。
この場合、CSV内の項目名「日時(yyyy/m/d h:mm)」は「日時」として扱えるようになります。
この「schema.ini」を使った方法は、Excel だけでなく Access 環境でも使えます。

今回の処理対象は1つのCSVファイルだけなので、Access に取り込んでから・・・
これは、優先順は低いかな・・・
複数のCSVを取り込んでから総合的に・・・なら最優先かも・・・かも・・・
 
回答した内容を紹介しておきます
Access が使える環境で、Excel から CSV に SQL 発行して・・・

以下処理を記述したExcel ファイル名を「xxxx.xlsm」
CSV ファイル名を「★★.csv」
CSV 情報ファイル「schema.ini」
これが同じフォルダにあるものとします。

「schema.ini」内に以下を記述しておきます(メモ帳ででも)

[★★.csv]
ColNameHeader=True
CharacterSet=932
Format=CSVDelimited
Col1=ID Char Width 255
Col2=日時 Date
Col3=備考1 Char Width 255
Col4=備考2 Char Width 255

Excel ファイルの標準モジュールに以下を記述し実行すると
新規シートに全部書き出します

Option Explicit

Private Const adStateOpen = 1
Private Const adOpenStatic = 3
Private Const adLockReadOnly = 1
Private Const PN2007 As String = "Microsoft.ACE.OLEDB.12.0"
Private Const PN2003 As String = "Microsoft.Jet.OLEDB.4.0"

Public Sub Samp1()
  Dim vA As Variant, v As Variant
  Dim cn As Object, rs As Object
  Dim sSql As String
  Dim i As Integer
  Dim sS As String
  Dim sPath As String ' CSV ファイルのパス
  Const sCsv As String = "★★.csv" ' CSV ファイル名

  On Error Resume Next
  sS = ThisWorkbook.FullName
  sPath = Left(sS, InStrRev(sS, "\") - 1)
  Set cn = CreateObject("ADODB.Connection")
  For Each v In Array(PN2007, PN2003)
    cn.Open "Provider=" & v & ";Data Source=" & sPath & ";" _
        & "Extended Properties='text;HDR=Yes;FMT=Delimited'"
    If (cn.State = adStateOpen) Then Exit For
  Next
  If (IsEmpty(v)) Then
    MsgBox "環境不足で処理中断", vbCritical
    Set cn = Nothing
    Exit Sub
  End If

  sSql = "SELECT Q1.ID, Format(Q1.日時,'yyyy/m/d h:nn') AS 日時, " _
    & "Q1.備考1, Q1.備考2 FROM [{%1}] AS Q1 INNER JOIN " _
    & "(SELECT Q2.ID, Q2.日時 FROM " _
    & "(SELECT ID, 日時, Int(日時) AS 日 FROM [{%1}]) AS Q2 " _
    & "INNER JOIN " _
    & "(SELECT ID, 日時, Int(日時) AS 日 FROM [{%1}]) AS Q3 " _
    & "ON Q2.ID=Q3.ID AND Q2.日=Q3.日 " _
    & "GROUP BY Q2.ID, Q2.日, Q2.日時 " _
    & "HAVING Q2.日時=Min(Q3.日時) OR Q2.日時=Max(Q3.日時) " _
    & ") AS Q4 " _
    & "ON Q1.ID=Q4.ID AND Q1.日時=Q4.日時 " _
    & "ORDER BY Q1.ID, Q1.日時;"

  Set rs = CreateObject("ADODB.Recordset")
  rs.Source = Replace(sSql, "{%1}", sCsv)
  rs.Open , cn, adOpenStatic, adLockReadOnly
  Worksheets.Add After:=ActiveSheet
  With Range("A1")
    For i = 0 To rs.fields.Count - 1
      .Offset(, i) = rs.fields(i).Name
    Next
    With .Offset(1)
      .CopyFromRecordset rs
      With .Offset(, 1).Resize(rs.RecordCount)
        .Value = .Value
      End With
    End With
    .CurrentRegion.EntireColumn.AutoFit
  End With
  rs.Close: Set rs = Nothing
  cn.Close: Set cn = Nothing
End Sub

※ ID をある程度の範囲でシート分割したい場合は
>  Set rs = CreateObject("ADODB.Recordset")
以降を以下に書き換えます
以下では、
ID "0001" ~ "0100" を1シートに
ID "0101" ~ "0200" を1シートに
分割します

  Set rs = CreateObject("ADODB.Recordset")
  rs.Source = Replace(sSql, "{%1}", sCsv)
  rs.Open , cn, adOpenStatic, adLockReadOnly

  vA = Array(Array("0001", "0100"), Array("0101", "0200"))

  For Each v In vA
    sS = v(0) & "_" & v(1)
    rs.Filter = "ID>='" & v(0) & "' AND ID<='" & v(1) & "'"
    Worksheets.Add After:=ActiveSheet
    ActiveSheet.Name = sS
    With Range("A1")
      For i = 0 To rs.fields.Count - 1
        .Offset(, i) = rs.fields(i).Name
      Next
      With .Offset(1)
        .CopyFromRecordset rs
        With .Offset(, 1).Resize(rs.RecordCount)
          .Value = .Value
        End With
      End With
      .CurrentRegion.EntireColumn.AutoFit
    End With
'    ActiveSheet.Move
'    With ActiveWorkbook
'      .SaveAs sPath & "\ID" & sS
'      .Close False
'    End With
  Next
  rs.Close: Set rs = Nothing
  cn.Close: Set cn = Nothing

※ 後半のコメント部分を有効にすると、シート単位でファイル分けします。

※ .CopyFromRecordset rs の後で、日時に書式を設定してましたが
シートを作り込んでいくと、前のシートの書式がおかしくなったので
SQLで文字列にしておいて、Excel上で、Excelさんに解釈してもらう様に
.Value = .Value しました。

※ 速さを求めた記述にはしていなかったので、
使えるものなのかは判断ください。
また、細かく検証していないので、不具合あればごめんなさい


今回のサンプルには以下が入ってます。

ファイル内容
 kEnt213.xlsm 主確認用Excelファイル
 kEnt213.xls 上記を保存時に変換したもの
 kEnt213_0.csv 確認用の小さいcsvファイル
 schema.ini csv情報ファイル

※ チョッと大きいCSVファイルは、以下を実行することで
kEnt213_1.csv / kEnt213_2.csv が出来上がります。
Public Sub TestData1()
  Dim ffn As Integer
  Dim dtB As Date, v As Variant
  Dim sA(3) As String
  Dim i As Long

  ffn = FreeFile()
  Open ThisWorkbook.Path & "\" & CCSV1 For Output As #ffn
  Print #ffn, "ID,日時,備考1,備考2"

  Randomize
  dtB = DateAdd("m", -1, Date)
  While (dtB <= Date)
    For i = 1 To 500
      sA(0) = Format(i, "0000")
      For Each v In MakeTimes()
        sA(1) = Format(dtB + v, "yyyy/m/d h:nn")
        sA(2) = String(Int(10 * Rnd()) + 1, Chr(Asc("A") + Int(26 * Rnd())))
        sA(3) = String(Int(10 * Rnd()) + 1, Chr(Asc("a") + Int(26 * Rnd())))
        Print #ffn, Join(sA, ",")
      Next
    Next
    dtB = dtB + 1
  Wend
  Close #ffn
End Sub

Public Sub TestData2()
  Dim ffn As Integer
  Dim dtB As Date, v As Variant
  Dim sA(4) As String
  Dim i As Long

  ffn = FreeFile()
  Open ThisWorkbook.Path & "\" & CCSV2 For Output As #ffn
  Print #ffn, "Grp,ID,日時,備考1,備考2"

  Randomize
  dtB = DateAdd("m", -1, Date)
  While (dtB <= Date)
    For i = 1 To 500
      sA(0) = Chr(Asc("A") + (i - 1) Mod 4) _
          & Format(((i - 1) Mod 5) + 1, "00")
      sA(1) = Format(i, "0000")
      For Each v In MakeTimes()
        sA(2) = Format(dtB + v, "yyyy/m/d h:nn")
        sA(3) = String(Int(10 * Rnd()) + 1, Chr(Asc("A") + Int(26 * Rnd())))
        sA(4) = String(Int(10 * Rnd()) + 1, Chr(Asc("a") + Int(26 * Rnd())))
        Print #ffn, Join(sA, ",")
      Next
    Next
    dtB = dtB + 1
  Wend
  Close #ffn
End Sub

Private Function MakeTimes() As Date()
  Dim dtR() As Date
  Dim i As Long, j As Long

  j = Int(4 * Rnd())
  ReDim dtR(j)
  For i = LBound(dtR) To j
    dtR(i) = TimeSerial(Int(24 * Rnd()), Int(60 * Rnd()), 0)
  Next
  MakeTimes = dtR
End Function

kEnt213_1.csv / kEnt213_2.csv の違いは、
kEnt213_1.csv
当初フォーマットの ID 数を 1 ~ 500 / 対象日を1か月にしたもの
kEnt213_2.csv
回答の流れで、ID毎にファイルにするのはどうか?・・・
で、質問者さんがグループという項目をCSVに付加して、グループ単位ではどうか・・・
それ用の ID 数を 1 ~ 500 / 対象日を1か月にしたもの

でも、簡単にグループを付加したCSVを作成できるのなら、
CSV作成時に、同一IDで、同一日の最小/最大部分のみにする処理すれば・・・

既にあるCSVの形式は変更し難い・・・・これを念頭に処理を考えてみて回答してみた。
以下記述はサンプル用に若干変更していますが、やっている事は同じ
Public Const CCSV0 As String = "kEnt213_0.csv"
Public Const CCSV1 As String = "kEnt213_1.csv"
Const sCsv As String = CCSV0 ' CSV ファイル名

Private Const adStateOpen = 1
Private Const adOpenStatic = 3
Private Const adLockReadOnly = 1
Private Const PN2007 As String = "Microsoft.ACE.OLEDB.12.0"
Private Const PN2003 As String = "Microsoft.Jet.OLEDB.4.0"

Public Sub Samp1()
  Dim vA As Variant, v As Variant
  Dim cn As Object, rs As Object
  Dim sSql As String
  Dim i As Integer
  Dim sS As String
  Dim sPath As String ' CSV ファイルのパス
'  Const sCsv As String = CCSV0 ' CSV ファイル名

  On Error Resume Next
  sS = ThisWorkbook.FullName
  sPath = Left(sS, InStrRev(sS, "\") - 1)
  Set cn = CreateObject("ADODB.Connection")
  For Each v In Array(PN2007, PN2003)
    cn.Open "Provider=" & v & ";Data Source=" & sPath & ";" _
        & "Extended Properties='text;HDR=Yes;FMT=Delimited'"
    If (cn.State = adStateOpen) Then Exit For
  Next
  If (IsEmpty(v)) Then
    MsgBox "環境不足で処理中断", vbCritical
    Set cn = Nothing
    Exit Sub
  End If

  sSql = "SELECT Q1.ID, Format(Q1.日時,'yyyy/m/d h:nn') AS 日時, " _
    & "Q1.備考1, Q1.備考2 FROM [{%1}] AS Q1 INNER JOIN " _
    & "(SELECT Q2.ID, Q2.日時 FROM " _
    & "(SELECT ID, 日時, Int(日時) AS 日 FROM [{%1}]) AS Q2 " _
    & "INNER JOIN " _
    & "(SELECT ID, 日時, Int(日時) AS 日 FROM [{%1}]) AS Q3 " _
    & "ON Q2.ID=Q3.ID AND Q2.日=Q3.日 " _
    & "GROUP BY Q2.ID, Q2.日, Q2.日時 " _
    & "HAVING Q2.日時=Min(Q3.日時) OR Q2.日時=Max(Q3.日時) " _
    & ") AS Q4 " _
    & "ON Q1.ID=Q4.ID AND Q1.日時=Q4.日時 " _
    & "ORDER BY Q1.ID, Q1.日時;"

  Set rs = CreateObject("ADODB.Recordset")
  rs.Source = Replace(sSql, "{%1}", sCsv)
  rs.Open , cn, adOpenStatic, adLockReadOnly
  Worksheets.Add After:=ActiveSheet
  With Range("A1")
    For i = 0 To rs.fields.Count - 1
      .Offset(, i) = rs.fields(i).Name
    Next
    With .Offset(1)
      .CopyFromRecordset rs
      With .Offset(, 1).Resize(rs.RecordCount)
        .Value = .Value
      End With
    End With
    .CurrentRegion.EntireColumn.AutoFit
  End With
  rs.Close: Set rs = Nothing
  cn.Close: Set cn = Nothing
End Sub


Public Sub Samp2()
  Dim vA As Variant, v As Variant
  Dim cn As Object, rs As Object
  Dim sSql As String
  Dim i As Integer
  Dim sS As String
  Dim sPath As String ' CSV ファイルのパス
'  Const sCsv As String = CCSV0 ' CSV ファイル名

  On Error Resume Next
  sS = ThisWorkbook.FullName
  sPath = Left(sS, InStrRev(sS, "\") - 1)
  Set cn = CreateObject("ADODB.Connection")
  For Each v In Array(PN2007, PN2003)
    cn.Open "Provider=" & v & ";Data Source=" & sPath & ";" _
        & "Extended Properties='text;HDR=Yes;FMT=Delimited'"
    If (cn.State = adStateOpen) Then Exit For
  Next
  If (IsEmpty(v)) Then
    MsgBox "環境不足で処理中断", vbCritical
    Set cn = Nothing
    Exit Sub
  End If

  sSql = "SELECT Q1.ID, Format(Q1.日時,'yyyy/m/d h:nn') AS 日時, " _
    & "Q1.備考1, Q1.備考2 FROM [{%1}] AS Q1 INNER JOIN " _
    & "(SELECT Q2.ID, Q2.日時 FROM " _
    & "(SELECT ID, 日時, Int(日時) AS 日 FROM [{%1}]) AS Q2 " _
    & "INNER JOIN " _
    & "(SELECT ID, 日時, Int(日時) AS 日 FROM [{%1}]) AS Q3 " _
    & "ON Q2.ID=Q3.ID AND Q2.日=Q3.日 " _
    & "GROUP BY Q2.ID, Q2.日, Q2.日時 " _
    & "HAVING Q2.日時=Min(Q3.日時) OR Q2.日時=Max(Q3.日時) " _
    & ") AS Q4 " _
    & "ON Q1.ID=Q4.ID AND Q1.日時=Q4.日時 " _
    & "ORDER BY Q1.ID, Q1.日時;"

  Set rs = CreateObject("ADODB.Recordset")
  rs.Source = Replace(sSql, "{%1}", sCsv)
  rs.Open , cn, adOpenStatic, adLockReadOnly

  Select Case sCsv
    Case CCSV0
      vA = Array(Array("0001", "0100"), Array("0101", "0200"))
    Case CCSV1
      vA = Array(Array("0001", "0100"), Array("0101", "0200"), _
            Array("0201", "0300"), Array("0301", "0400"), _
            Array("0401", "0500"))
  End Select

  For Each v In vA
    sS = v(0) & "_" & v(1)
    rs.Filter = "ID>='" & v(0) & "' AND ID<='" & v(1) & "'"
    Worksheets.Add After:=ActiveSheet
    ActiveSheet.Name = sS
    With Range("A1")
      For i = 0 To rs.fields.Count - 1
        .Offset(, i) = rs.fields(i).Name
      Next
      With .Offset(1)
        .CopyFromRecordset rs
        With .Offset(, 1).Resize(rs.RecordCount)
          .Value = .Value
        End With
      End With
      .CurrentRegion.EntireColumn.AutoFit
    End With
'    ActiveSheet.Move
'    With ActiveWorkbook
'      .SaveAs sPath & "\ID" & sS
'      .Close False
'    End With
  Next
  rs.Close: Set rs = Nothing
  cn.Close: Set cn = Nothing
End Sub

 
※ Win2k + Office2000 では、Samp2 は、うまく動かないようです。
    rs.Filter = "ID>='" & v(0) & "' AND ID<='" & v(1) & "'"
は、処理されていない感じ・・・・
(1つ目のシートに全部、残りのシートは項目だけで空っぽ)
XP Pro + Office2003 / Vista + Office2007 では大丈夫でした。

        With .Offset(, 1).Resize(rs.RecordCount)
          .Value = .Value
        End With
この部分、回答時にも言ってましたが、以下書式で対応しようとすると
        With .Offset(, 1).Resize(rs.RecordCount)
          .NumberFormatLocal = "yyyy/m/d h:mm"
        End With
次々とシートを作っていくと、前のシートの書式が無効?変になる・・・
なので、Excel さんに解釈してもらおうかと・・・・ .Value = .Value に
書式(NumberFormatLocal)を設定する時には、SQL 内
Format(Q1.日時,'yyyy/m/d h:nn') AS 日時
は、Format しないでおきます。

※ sSql 部分は、書き方によって処理速度が結構違くなります
動けば良い・・・そのレベルで回答していました。
質問者さんが1度でも動かしてみて・・・ 遅い・・・
・・・となったら次に提示しようとしていたものは以下になります。
  sSql = "SELECT Q1.ID, Format(Q1.日時,'yyyy/m/d h:nn') AS 日時, " _
    & "Q1.備考1, Q1.備考2 FROM [{%1}] AS Q1 INNER JOIN " _
    & "(SELECT ID, Min(日時) AS 日 FROM [{%1}] GROUP BY ID, Int(日時) " _
    & "UNION ALL " _
    & "SELECT ID, Max(日時) AS 日 FROM [{%1}] GROUP BY ID, Int(日時) " _
    & ") AS Q2 ON Q1.ID=Q2.ID AND Q1.日時=Q2.日 " _
    & "ORDER BY Q1.ID, Q1.日時;"
ま、他回答者さんの内容に近いものなので、違うやり方で動くものにしてました・・・
(これでも同じ回答内容にはなっていないけど・・・)

質問者さんが方向転換する前の、
・ID毎のBook もしくは ID毎のシートに・・・・
をやってみたのが以下の Samp3

ID順で並ぶので、
・AbsolutePosition を使って
・その位置にある ID を使って Filter
・Filter されたものを処理後、AbsolutePosition 解釈位置更新
    j = j + rs.RecordCount
・Filter 解除して・・・・これを繰り返す

Public Sub Samp3()
  Dim vA As Variant, v As Variant
  Dim cn As Object, rs As Object
  Dim sSql As String
  Dim i As Integer, j As Long
  Dim sS As String
  Dim sPath As String ' CSV ファイルのパス
'  Const sCsv As String = CCSV0 ' CSV ファイル名

  On Error Resume Next
  sS = ThisWorkbook.FullName
  sPath = Left(sS, InStrRev(sS, "\") - 1)
  Set cn = CreateObject("ADODB.Connection")
  For Each v In Array(PN2007, PN2003)
    cn.Open "Provider=" & v & ";Data Source=" & sPath & ";" _
        & "Extended Properties='text;HDR=Yes;FMT=Delimited'"
    If (cn.State = adStateOpen) Then Exit For
  Next
  If (IsEmpty(v)) Then
    MsgBox "環境不足で処理中断", vbCritical
    Set cn = Nothing
    Exit Sub
  End If

  sSql = "SELECT Q1.ID, Format(Q1.日時,'yyyy/m/d h:nn') AS 日時, " _
    & "Q1.備考1, Q1.備考2 FROM [{%1}] AS Q1 INNER JOIN " _
    & "(SELECT Q2.ID, Q2.日時 FROM " _
    & "(SELECT ID, 日時, Int(日時) AS 日 FROM [{%1}]) AS Q2 " _
    & "INNER JOIN " _
    & "(SELECT ID, 日時, Int(日時) AS 日 FROM [{%1}]) AS Q3 " _
    & "ON Q2.ID=Q3.ID AND Q2.日=Q3.日 " _
    & "GROUP BY Q2.ID, Q2.日, Q2.日時 " _
    & "HAVING Q2.日時=Min(Q3.日時) OR Q2.日時=Max(Q3.日時) " _
    & ") AS Q4 " _
    & "ON Q1.ID=Q4.ID AND Q1.日時=Q4.日時 " _
    & "ORDER BY Q1.ID, Q1.日時;"

  Set rs = CreateObject("ADODB.Recordset")
  rs.Source = Replace(sSql, "{%1}", sCsv)
  rs.Open , cn, adOpenStatic, adLockReadOnly
  j = 1
  While (j <= rs.RecordCount)
    rs.AbsolutePosition = j
    sS = rs("ID")
    rs.Filter = "ID='" & sS & "'"
    Worksheets.Add After:=ActiveSheet
    ActiveSheet.Name = sS
    With Range("A1")
      For i = 0 To rs.fields.Count - 1
        .Offset(, i) = rs.fields(i).Name
      Next
      With .Offset(1)
        .CopyFromRecordset rs
        With .Offset(, 1).Resize(rs.RecordCount)
          .Value = .Value
        End With
      End With
      .CurrentRegion.EntireColumn.AutoFit
    End With
'    ActiveSheet.Move
'    With ActiveWorkbook
'      .SaveAs sPath & "\ID" & sS
'      .Close
'    End With
    j = j + rs.RecordCount
    rs.Filter = ""
  Wend
  rs.Close: Set rs = Nothing
  cn.Close: Set cn = Nothing
End Sub

 
※ ここで示した Samp1 ~ Samp3 で、処理対象CSVを切り替えるのは、記述先頭にある
Public Const CCSV0 As String = "kEnt213_0.csv"
Public Const CCSV1 As String = "kEnt213_1.csv"
Const sCsv As String = CCSV0 ' CSV ファイル名
部分を書き換えるだけです。
処理対象を CCSV1 (kEnt213_1.csv) に変更した場合、Samp3 の実行には注意してください。
というのは、ID数 500 になっているので、500 シート作る動きをします。
環境によっては、500 シート作成できずに、おかしくなるかもしれません。
その時には、以下のコメント部分を有効にするとID毎にファイルを作成します。


簡単にCSVの項目を増やした後の確認用は、Samp41 ~ Samp43 になります。

Samp1 を継承したのが Samp41
Samp2 を継承したのが Samp42 / Samp422
ここでは、レコードセットをもう1つ用意し、グループの重複なしを求めておいて
Samp42 では、Filter でグループ単位に絞る
Samp422 では、グループ毎に抽出し直す
Samp42 の方が全体の時間は Samp422 より速そうだけど・・・1グループだけ・・・なら Samp422
Samp3 を継承したのが Samp43

※ なお、kEnt213_1.csv / kEnt213_2.csv は作成しないと存在しないので・・・
冒頭での TestData1() / TestData2() を実行して作っておいてください。
(それ用のエラー処理は入れていないので・・・)

※ 主だった変更部分は、黄色で示しています
実行確認される場合、Samp42 / Samp422 / Samp43 は注意してください。
(シート名が被るようになります)

Option Explicit

Public Const CCSV2 As String = "kEnt213_2.csv"
Const sCsv As String = CCSV2 ' CSV ファイル名

Private Const adStateOpen = 1
Private Const adOpenStatic = 3
Private Const adLockReadOnly = 1
Private Const PN2007 As String = "Microsoft.ACE.OLEDB.12.0"
Private Const PN2003 As String = "Microsoft.Jet.OLEDB.4.0"

Public Sub Samp41()
  Dim vA As Variant, v As Variant
  Dim cn As Object, rs As Object
  Dim sSql As String
  Dim i As Integer
  Dim sS As String
  Dim sPath As String ' CSV ファイルのパス
'  Const sCsv As String = CCSV0 ' CSV ファイル名

  On Error Resume Next
  sS = ThisWorkbook.FullName
  sPath = Left(sS, InStrRev(sS, "\") - 1)
  Set cn = CreateObject("ADODB.Connection")
  For Each v In Array(PN2007, PN2003)
    cn.Open "Provider=" & v & ";Data Source=" & sPath & ";" _
        & "Extended Properties='text;HDR=Yes;FMT=Delimited'"
    If (cn.State = adStateOpen) Then Exit For
  Next
  If (IsEmpty(v)) Then
    MsgBox "環境不足で処理中断", vbCritical
    Set cn = Nothing
    Exit Sub
  End If

  sSql = "SELECT Q1.Grp, Q1.ID, Format(Q1.日時,'yyyy/m/d h:nn') AS 日時, " _
    & "Q1.備考1, Q1.備考2 FROM [{%1}] AS Q1 INNER JOIN " _
    & "(SELECT Q2.ID, Q2.日時 FROM " _
    & "(SELECT ID, 日時, Int(日時) AS 日 FROM [{%1}]) AS Q2 " _
    & "INNER JOIN " _
    & "(SELECT ID, 日時, Int(日時) AS 日 FROM [{%1}]) AS Q3 " _
    & "ON Q2.ID=Q3.ID AND Q2.日=Q3.日 " _
    & "GROUP BY Q2.ID, Q2.日, Q2.日時 " _
    & "HAVING Q2.日時=Min(Q3.日時) OR Q2.日時=Max(Q3.日時) " _
    & ") AS Q4 " _
    & "ON Q1.ID=Q4.ID AND Q1.日時=Q4.日時 " _
    & "ORDER BY Q1.Grp, Q1.ID, Q1.日時;"

  Set rs = CreateObject("ADODB.Recordset")
  rs.Source = Replace(sSql, "{%1}", sCsv)
  rs.Open , cn, adOpenStatic, adLockReadOnly
  Worksheets.Add After:=ActiveSheet
  With Range("A1")
    For i = 0 To rs.fields.Count - 1
      .Offset(, i) = rs.fields(i).Name
    Next
    With .Offset(1)
      .CopyFromRecordset rs
      With .Offset(, 2).Resize(rs.RecordCount)
        .Value = .Value
      End With
    End With
    .CurrentRegion.EntireColumn.AutoFit
  End With
  rs.Close: Set rs = Nothing
  cn.Close: Set cn = Nothing
End Sub


Public Sub Samp42()
  Dim vA As Variant, v As Variant
  Dim cn As Object, rs As Object, rsP As Object
  Dim sSql As String
  Dim i As Integer
  Dim sS As String
  Dim sPath As String ' CSV ファイルのパス
'  Const sCsv As String = CCSV0 ' CSV ファイル名

  On Error Resume Next
  sS = ThisWorkbook.FullName
  sPath = Left(sS, InStrRev(sS, "\") - 1)
  Set cn = CreateObject("ADODB.Connection")
  For Each v In Array(PN2007, PN2003)
    cn.Open "Provider=" & v & ";Data Source=" & sPath & ";" _
        & "Extended Properties='text;HDR=Yes;FMT=Delimited'"
    If (cn.State = adStateOpen) Then Exit For
  Next
  If (IsEmpty(v)) Then
    MsgBox "環境不足で処理中断", vbCritical
    Set cn = Nothing
    Exit Sub
  End If

  sSql = "SELECT Q1.Grp, Q1.ID, Format(Q1.日時,'yyyy/m/d h:nn') AS 日時, " _
    & "Q1.備考1, Q1.備考2 FROM [{%1}] AS Q1 INNER JOIN " _
    & "(SELECT Q2.ID, Q2.日時 FROM " _
    & "(SELECT ID, 日時, Int(日時) AS 日 FROM [{%1}]) AS Q2 " _
    & "INNER JOIN " _
    & "(SELECT ID, 日時, Int(日時) AS 日 FROM [{%1}]) AS Q3 " _
    & "ON Q2.ID=Q3.ID AND Q2.日=Q3.日 " _
    & "GROUP BY Q2.ID, Q2.日, Q2.日時 " _
    & "HAVING Q2.日時=Min(Q3.日時) OR Q2.日時=Max(Q3.日時) " _
    & ") AS Q4 " _
    & "ON Q1.ID=Q4.ID AND Q1.日時=Q4.日時 " _
    & "ORDER BY Q1.Grp, Q1.ID, Q1.日時;"

  Set rs = CreateObject("ADODB.Recordset")
  rs.Source = Replace(sSql, "{%1}", sCsv)
  rs.Open , cn, adOpenStatic, adLockReadOnly

  Set rsP = CreateObject("ADODB.Recordset")
  rsP.Source = "SELECT DISTINCT Grp FROM [" & sCsv & "];"
  rsP.Open , cn, adOpenStatic, adLockReadOnly


  While (Not rsP.EOF)
    rs.Filter = "Grp='" & rsP(0) & "'"
    Worksheets.Add After:=ActiveSheet
    ActiveSheet.Name = rsP(0)
    With Range("A1")
      For i = 0 To rs.fields.Count - 1
        .Offset(, i) = rs.fields(i).Name
      Next
      With .Offset(1)
        .CopyFromRecordset rs
        With .Offset(, 2).Resize(rs.RecordCount)
          .Value = .Value
        End With
      End With
      .CurrentRegion.EntireColumn.AutoFit
    End With
'    ActiveSheet.Move
'    With ActiveWorkbook
'      .SaveAs sPath & "\Grp" & rsP(0)
'      .Close False
'    End With
    rsP.MoveNext
  Wend
  rsP.Close: Set rsP = Nothing
  rs.Close: Set rs = Nothing
  cn.Close: Set cn = Nothing
End Sub


Public Sub Samp422()
  Dim vA As Variant, v As Variant
  Dim cn As Object, rs As Object, rsP As Object
  Dim sSql As String
  Dim i As Integer
  Dim sS As String
  Dim sPath As String ' CSV ファイルのパス
'  Const sCsv As String = CCSV0 ' CSV ファイル名

  On Error Resume Next
  sS = ThisWorkbook.FullName
  sPath = Left(sS, InStrRev(sS, "\") - 1)
  Set cn = CreateObject("ADODB.Connection")
  For Each v In Array(PN2007, PN2003)
    cn.Open "Provider=" & v & ";Data Source=" & sPath & ";" _
        & "Extended Properties='text;HDR=Yes;FMT=Delimited'"
    If (cn.State = adStateOpen) Then Exit For
  Next
  If (IsEmpty(v)) Then
    MsgBox "環境不足で処理中断", vbCritical
    Set cn = Nothing
    Exit Sub
  End If

  sSql = "SELECT Q1.Grp, Q1.ID, Format(Q1.日時,'yyyy/m/d h:nn') AS 日時, " _
    & "Q1.備考1, Q1.備考2 FROM [{%1}] AS Q1 INNER JOIN " _
    & "(SELECT Q2.ID, Q2.日時 FROM " _
    & "(SELECT ID, 日時, Int(日時) AS 日 FROM [{%1}] " _
    & "WHERE Grp='{%2}') AS Q2 " _
    & "INNER JOIN " _
    & "(SELECT ID, 日時, Int(日時) AS 日 FROM [{%1}] " _
    & "WHERE Grp='{%2}') AS Q3 " _
    & "ON Q2.ID=Q3.ID AND Q2.日=Q3.日 " _
    & "GROUP BY Q2.ID, Q2.日, Q2.日時 " _
    & "HAVING Q2.日時=Min(Q3.日時) OR Q2.日時=Max(Q3.日時) " _
    & ") AS Q4 " _
    & "ON Q1.ID=Q4.ID AND Q1.日時=Q4.日時 " _
    & "ORDER BY Q1.Grp, Q1.ID, Q1.日時;"

  sSql = Replace(sSql, "{%1}", sCsv)
  Set rsP = CreateObject("ADODB.Recordset")
  rsP.Source = "SELECT DISTINCT Grp FROM [" & sCsv & "];"
  rsP.Open , cn, adOpenStatic, adLockReadOnly

  Set rs = CreateObject("ADODB.Recordset")
  While (Not rsP.EOF)
    rs.Source = Replace(sSql, "{%2}", rsP(0))
    rs.Open , cn, adOpenStatic, adLockReadOnly


    Worksheets.Add After:=ActiveSheet
    ActiveSheet.Name = rsP(0)
    With Range("A1")
      For i = 0 To rs.fields.Count - 1
        .Offset(, i) = rs.fields(i).Name
      Next
      With .Offset(1)
        .CopyFromRecordset rs
        With .Offset(, 2).Resize(rs.RecordCount)
          .Value = .Value
        End With
      End With
      .CurrentRegion.EntireColumn.AutoFit
    End With
    rs.Close
'    ActiveSheet.Move
'    With ActiveWorkbook
'      .SaveAs sPath & "\Grp" & rsP(0)
'      .Close False
'    End With
    rsP.MoveNext
  Wend
  rsP.Close: Set rsP = Nothing
  Set rs = Nothing
  cn.Close: Set cn = Nothing
End Sub


Public Sub Samp43()
  Dim vA As Variant, v As Variant
  Dim cn As Object, rs As Object
  Dim sSql As String
  Dim i As Integer, j As Long
  Dim sS As String
  Dim sPath As String ' CSV ファイルのパス
'  Const sCsv As String = CCSV0 ' CSV ファイル名

  On Error Resume Next
  sS = ThisWorkbook.FullName
  sPath = Left(sS, InStrRev(sS, "\") - 1)
  Set cn = CreateObject("ADODB.Connection")
  For Each v In Array(PN2007, PN2003)
    cn.Open "Provider=" & v & ";Data Source=" & sPath & ";" _
        & "Extended Properties='text;HDR=Yes;FMT=Delimited'"
    If (cn.State = adStateOpen) Then Exit For
  Next
  If (IsEmpty(v)) Then
    MsgBox "環境不足で処理中断", vbCritical
    Set cn = Nothing
    Exit Sub
  End If

  sSql = "SELECT Q1.Grp, Q1.ID, Format(Q1.日時,'yyyy/m/d h:nn') AS 日時, " _
    & "Q1.備考1, Q1.備考2 FROM [{%1}] AS Q1 INNER JOIN " _
    & "(SELECT Q2.ID, Q2.日時 FROM " _
    & "(SELECT ID, 日時, Int(日時) AS 日 FROM [{%1}]) AS Q2 " _
    & "INNER JOIN " _
    & "(SELECT ID, 日時, Int(日時) AS 日 FROM [{%1}]) AS Q3 " _
    & "ON Q2.ID=Q3.ID AND Q2.日=Q3.日 " _
    & "GROUP BY Q2.ID, Q2.日, Q2.日時 " _
    & "HAVING Q2.日時=Min(Q3.日時) OR Q2.日時=Max(Q3.日時) " _
    & ") AS Q4 " _
    & "ON Q1.ID=Q4.ID AND Q1.日時=Q4.日時 " _
    & "ORDER BY Q1.Grp, Q1.ID, Q1.日時;"

  Set rs = CreateObject("ADODB.Recordset")
  rs.Source = Replace(sSql, "{%1}", sCsv)
  rs.Open , cn, adOpenStatic, adLockReadOnly
  j = 1
  While (j <= rs.RecordCount)
    rs.AbsolutePosition = j
    sS = rs("Grp")
    rs.Filter = "Grp='" & sS & "'"

    Worksheets.Add After:=ActiveSheet
    ActiveSheet.Name = sS
    With Range("A1")
      For i = 0 To rs.fields.Count - 1
        .Offset(, i) = rs.fields(i).Name
      Next
      With .Offset(1)
        .CopyFromRecordset rs
        With .Offset(, 2).Resize(rs.RecordCount)
          .Value = .Value
        End With
      End With
      .CurrentRegion.EntireColumn.AutoFit
    End With
'    ActiveSheet.Move
'    With ActiveWorkbook
'      .SaveAs sPath & "\ID" & sS
'      .SaveAs sPath & "\Grp" & sS '上記はこっちに変更した方が・・・
'      .Close
'    End With
    j = j + rs.RecordCount
    rs.Filter = ""
  Wend
  rs.Close: Set rs = Nothing
  cn.Close: Set cn = Nothing
End Sub

 
※ これらに記述した sSql も書き方を変えるだけで処理速度が変わります
(1度確認されたら、以下に書き換えて確認されてみるのはどうでしょう)
Samp41 / Samp42 / Samp43 用
 sSql = "SELECT Q1.Grp, Q1.ID, Format(Q1.日時,'yyyy/m/d h:nn') AS 日時, " _
   & "Q1.備考1, Q1.備考2 FROM [{%1}] AS Q1 INNER JOIN " _
   & "(SELECT ID, Min(日時) AS 日 FROM [{%1}] GROUP BY ID, Int(日時) " _
   & "UNION ALL " _
   & "SELECT ID, Max(日時) AS 日 FROM [{%1}] GROUP BY ID, Int(日時) " _
   & ") AS Q2 ON Q1.ID=Q2.ID AND Q1.日時=Q2.日 " _
   & "ORDER BY Q1.Grp, Q1.ID, Q1.日時;"

Samp422 用
 sSql = "SELECT Q1.Grp, Q1.ID, Format(Q1.日時,'yyyy/m/d h:nn') AS 日時, " _
   & "Q1.備考1, Q1.備考2 FROM [{%1}] AS Q1 INNER JOIN " _
   & "(SELECT ID, Min(日時) AS 日 FROM [{%1}] WHERE Grp='{%2}' GROUP BY ID, Int(日時) " _
   & "UNION ALL " _
   & "SELECT ID, Max(日時) AS 日 FROM [{%1}] WHERE Grp='{%2}' GROUP BY ID, Int(日時) " _
   & ") AS Q2 ON Q1.ID=Q2.ID AND Q1.日時=Q2.日 " _
   & "ORDER BY Q1.Grp, Q1.ID, Q1.日時;"


※ これらの確認は、Access さんが動ける環境下で Excel にて処理するものなので・・・

あっ、そうそう・・・
'    ActiveSheet.Move
'    With ActiveWorkbook
'      .SaveAs sPath & "\Grp" & rsP(0)
'      .Close False
'    End With
この部分、説明しておいた方が良いかな?
シートの Move に引数が無いと、新規ブックが作成されその中に移動します。
( Copy も同じ動作ですね)
その新しいブックがアクティブになるので、名前を指定して保存後、ブックを閉じる・・・・
また、名前に拡張子を付けていないので、Excel のバージョンで勝手に処理してくれたかな?

動作を確認したいので画面がパカパカと変わっていきますが・・・・
実際には、Application.ScreenUpdating で画面更新を抑止しても良いかも?
その際には、進行状況をどう伝えるか・・・等々盛り込めば良さそうです。

各関数の処理先頭で On Error Resume Next してますが、
On Error GoTo 0 することも考えてみては・・・
現状では、関数を連続実行した際にシート名が被ったとか・・・・
その際にも有効なものになってます

また、ファイルとして保存時に既に存在したら、上書き確認ダイアログが表示されますが、
Application.DisplayAlerts を使って強制上書きにしてみても良いかも・・・

今回のCSVのフォーマットは一般的なのかな?
というのは、文字列部分を " " で囲っていない・・・・
これらCSVをダブルクリックすると、Excelさんが立ち上がる?
その際に、あ~だこ~だと Excelさんがメッセージ出してくる・・・
ようやく開けたかと思ったら、ID部分は4桁の文字列じゃなく数値・・・
ADO経由では、うまく動いてくれたんだけど・・・・
まっ、解決したという事だから・・・ もう忘れよう・・・


サンプルは以下
 バージョン 2000 でも
 ファイル kEnt213.zip
 サイズ 43,670
※ ファイルは zip 形式
※ 2007 で作成した Excel ファイルも(互換:xls)
※ 冒頭で記述した4ファイルがフォルダごと

フォルダ毎を解凍していじってみてください。

最近は回答しても・・・ 気持ちが・・・ 心が・・・ 虚しくなるばかり
動いたとか・・・・ 動かなかったとか・・・・ それすらも伝えようとはしないのだろうか

初心者という事で、簡単な記述を使って・・・・
処理の流れを自分で考えてもらいたかったから・・・ コメント書かず
コメントで処理が隠れるよりは良いと思うんだけど・・・

虚しくなるのも嫌だから・・・・
回答したつもり・・・ で、記事を増やしていこうかな・・・・
でも、サンプル作ったら、説明用の文章も書かなくては・・・・
これ、面倒だから記事数が伸びないんですけどね・・・
関連記事

2015/05/26

Category: サンプルかな

TB: --  /  CM: 0

top △

この記事に対するコメント

top △

コメントの投稿

Secret

top △


上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。