人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

質問です。データはCSVファイルで2行目からです。7ファイルに各5000件位あります。
B列コード G列(日付の数) H列(データの個数) I列(0の数) J列(文字の数)
BBBB 2011/4/16 22:25 0 0 DoCoMo
コード毎一覧集計リストのマクロをお願いします。G列の答えはE列にお願いします。
項目名A列にコード、B列に件数、C列にエラー、D列に返信、E列に日付

●質問者: inosisi
●カテゴリ:コンピュータ インターネット
✍キーワード:CSV DoCoMo エラー コード データ
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● きゃづみぃ
●35ポイント

このマクロを実行するブックのシートを二つ利用します。

ひとつが ファイルを読み込んで集計用。

その集計したのを 切り取って貼り付けるのが もう二つめのシートです。

なので 最終的には 二つ目のシートに結果が残ります。

なお、結果は ファイル単位で 出力されますので ソートしていません。


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

p = "C:\test\"

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

End Sub


Sub jikkou(p As String, s As String)

Dim bk As Workbook
Application.DisplayAlerts = False
 
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
 Debug.Print .Cells(b, ck)
 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
 r = ThisWorkbook.Sheets(1).Cells(1, "A").End(xlDown).Row + 1
 End If
 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)
 
 Next b

 End With
 
 w.Close
 
  'シート2にシート1の内容を移動させる
 r = ThisWorkbook.Sheets(1).Cells(1, "A").End(xlDown).Row + 1
 r2 = ThisWorkbook.Sheets(2).Cells(2, "A").End(xlDown).Row + 1
 
 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

◎質問者からの返答

ありがとうがざいます。

一応上手くいったんですが

集計は

最初のコードにはちゃんと集計しています

4コードあるうち最後のコードに3コード一緒に合計しています

間の2コードはありません

4ファイルの中に各4コードづつあるのですが

各ファイル同じように2コードづつしかできていません

2コード目から4コードまでをコード毎に集計するよう修正できますか。

よろしくお願いします。


2 ● きゃづみぃ
●35ポイント ベストアンサー

修正しました。

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

p = "C:\test\"

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

End Sub


Sub jikkou(p As String, s As String)

Dim bk As Workbook
Application.DisplayAlerts = False
 
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
 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
 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)
 
 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

◎質問者からの返答

ありがとうございました。

うまく行きました。素晴らしいです。

細かいとこですが0の表示がでないので

0が表示されると完璧です。

よろしくお願いします。

いろいろご無理言ってすみませんでした。

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ