質問です。データは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列に日付

回答の条件
  • 1人10回まで
  • 13歳以上
  • 登録:2011/05/15 19:36:31
  • 終了:2011/05/18 12:43:02

ベストアンサー

id:taknt No.2

きゃづみぃ回答回数13537ベストアンサー獲得回数11982011/05/18 10:15:02

ポイント35pt

修正しました。

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

id:inosisi4141

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

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

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

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

よろしくお願いします。

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

2011/05/18 11:57:01

その他の回答(1件)

id:taknt No.1

きゃづみぃ回答回数13537ベストアンサー獲得回数11982011/05/17 15:35:14

ポイント35pt

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

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

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

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

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


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

id:inosisi4141

ありがとうがざいます。

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

集計は

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

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

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

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

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

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

よろしくお願いします。

2011/05/17 19:16:35
id:taknt No.2

きゃづみぃ回答回数13537ベストアンサー獲得回数11982011/05/18 10:15:02ここでベストアンサー

ポイント35pt

修正しました。

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

id:inosisi4141

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

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

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

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

よろしくお願いします。

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

2011/05/18 11:57:01
  • id:taknt
    最後に書いてある
    >項目名A列にコード、B列に件数、C列にエラー、D列に返信、E列に日付
    は 何でしょうか?
  • id:inosisi4141
    お世話様です。
    結果を一覧にして表示する項目名です(変更可能な)

    A列   B列   C列  D列   E列   F列
    コード  件数   エラー 返信   日付   ファイル名
    BBB   1   1    1    1    abc.csv

    1行目 項目名
    2行目以降は 答えのデータ
    最初のG列の答えはE列の日付の行に
    F列には各データが入っていたファイル名を表示したいのですが。
    各ファイル名ごとにソートし一覧表示する

    よろしくお願いします。


       
  • id:taknt
    C列  D列のエラー 返信は 何でしょうか?

    あと 日付の月/日/年になってたのは 大丈夫ですか?
  • id:inosisi4141
    下記はabc.csvファイル名の中のデータCSV
    B列 G列 H列 I列 J列
    コード (日付の数)    (データの件数)  (0の数)   (文字の数) 
    BBBB  2011/4/16 22:25   0      0     DoCoMo
    BBBB 0000-00-00 00:00:00 1 0
    BBBB 2011/4/16 22:25 0 1 DoCoMo


    一覧表の結果表示

         A列(B)  B列(H)   C列(I) D列(J)   E列(G)  F列
    項目名 コード   件数   エラー   返信   日付  ファイル名 
        BBBB    3   2     2  2 abc  


    C列      D列のエラー 返信は 何でしょうか?
    I列の0の数   J列の文字の数  


    あと 日付の月/日/年になってたのは 大丈夫ですか?
    当面そのままでやる予定です。

    よろしくお願いします。

  • id:inosisi4141
    あと 日付の月/日/年になってたのは 大丈夫ですか?

    xlsxの拡張子でやったらできました。
    そうすると分割後に保存するときか保存した後に
    xlsxのエクセル拡張子で保存できると良いですね

    日付変換後またcsvの拡張子に変換する作業が必要に
    なりますが

    何か良い方法がありましたらお教えてください。
    よろしくお願いします。
  • id:taknt
    日付は 集計のみなので 関係なかったですね。


    >xlsxのエクセル拡張子で保存できると良いですね
    新規作成するときに xlsxにしないと いけないのかな。

    ちなみに xlsxは 2007用の拡張子ですね。
    私が普段利用している環境は 2000だから 確認できません。
  • id:inosisi4141
    >xlsxのエクセル拡張子で保存できると良いですね

    現在はcsvの拡張子では日付変換ができないので
    xlsxの拡張子であれば日付変換ができます。
    csvで分割しcsvで保存この状態では日付は直っていない
    一旦xlsxに保存して日付変換マクロで実行すると変換します
    xlsでもよいのでなにかできますか
    csvで分割してxlsで保存できるようになりますか。
  • id:taknt
    0を入れました。

    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

    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)

    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

  • id:inosisi4141
    ありがとうございました。
    完璧なできあがりです。
    ご無理を言って申し訳ありませんでした。
    今後もよろしくお願いいたします。

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

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

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

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