1306735390 質問です。

エクセルでD列に男女の性別、G列に金額(正数と負数)、J列に日付
のデータがあります。データは2行目からです。
データはCSVファイルをc\test\に置いて
別ファイルSheet1に正数の答え、Sheet2に負数の答え、Sheet3に正負合計の結果一覧を作成するマクロをお願いします。
c\test\のエクセルCSVデータ
D列   G列   J列
性別  金額   日付
女  -10,000  2011/5/1

答えの一覧表は
Sheet1に正数の一覧集計
Sheet2に負数の一覧集計
Sheet3にその合計の一覧集計
の3個の一覧表
各sheetに日付ごとに男女別の男女の人数と金額の集計表を作成。
項目名はこちらで入力します。答えは2行目からおねがいします。
画像を添付しておりますので参照おねがいします。

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2011/05/30 15:03:07
  • 終了:2011/05/31 10:19:42

ベストアンサー

id:taknt No.3

きゃづみぃ回答回数13539ベストアンサー獲得回数11982011/05/30 19:23:40

ポイント33pt

Function Convert_Date(a As String) As Date 以降が 入りきれてなかったので

入れなおしてください。

文字数制限で ソースが 長すぎて ダメだったようです。

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

その他の回答(2件)

id:taknt No.1

きゃづみぃ回答回数13539ベストアンサー獲得回数11982011/05/30 17:16:39

ポイント34pt

これは ちょっと作るのに 時間かかったなぁ・・・。

Sub main()
Dim p As String

'集計対象シート初期化
    
ThisWorkbook.Sheets("Sheet1").Cells.Delete Shift:=xlUp
ThisWorkbook.Sheets("Sheet2").Cells.Delete Shift:=xlUp
ThisWorkbook.Sheets("Sheet3").Cells.Delete Shift:=xlUp


'見出しセット
ThisWorkbook.Sheets("Sheet1").Range("B1") = "男性"
ThisWorkbook.Sheets("Sheet1").Range("C1") = "金額計"
ThisWorkbook.Sheets("Sheet1").Range("D1") = "女性"
ThisWorkbook.Sheets("Sheet1").Range("E1") = "金額計"
ThisWorkbook.Sheets("Sheet1").Range("F1") = "男女計"
ThisWorkbook.Sheets("Sheet1").Range("G1") = "金額合計"

ThisWorkbook.Sheets("Sheet2").Range("B1") = "男性"
ThisWorkbook.Sheets("Sheet2").Range("C1") = "金額計"
ThisWorkbook.Sheets("Sheet2").Range("D1") = "女性"
ThisWorkbook.Sheets("Sheet2").Range("E1") = "金額計"
ThisWorkbook.Sheets("Sheet2").Range("F1") = "男女計"
ThisWorkbook.Sheets("Sheet2").Range("G1") = "金額合計"

ThisWorkbook.Sheets("Sheet3").Range("B1") = "男性"
ThisWorkbook.Sheets("Sheet3").Range("C1") = "金額計"
ThisWorkbook.Sheets("Sheet3").Range("D1") = "女性"
ThisWorkbook.Sheets("Sheet3").Range("E1") = "金額計"
ThisWorkbook.Sheets("Sheet3").Range("F1") = "男女計"
ThisWorkbook.Sheets("Sheet3").Range("G1") = "金額合計"


'対象フォルダを指定してください。
'このフォルダに この実行用のブックは 入れないでください。
p = "C:\test\"

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

End Sub


Sub jikkou(p As String, s As String)

Dim bk As Workbook
Dim b1 As String
Dim ab As String

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 = "D"        'チェックする列
        
        For b = kg To .Cells(kg, ck).End(xlDown).Row
            
            da = .Cells(b, "H")
            If Len(da) >= 8 Then
                aa = InStr(1, da, " ")
                ab = Left(da, aa - 1)
                da = Convert_Date(ab)
            End If
            
            '計
            ss = "Sheet3"
            dd = ThisWorkbook.Sheets(ss).Range("G1").End(xlDown).Row
            If ThisWorkbook.Sheets(ss).Range("G2") = "" Then
                dd = 2
            End If
            
            f = 0
            For c = 2 To dd
                If ThisWorkbook.Sheets(ss).Cells(c, "A") = "" Then
                    ThisWorkbook.Sheets(ss).Cells(c, "A") = da
                    
                    If InStr(1, .Cells(b, "D"), "男") > 0 Then
                        ThisWorkbook.Sheets(ss).Cells(c, "B") = 1
                        ThisWorkbook.Sheets(ss).Cells(c, "C") = .Cells(b, "G")
                        ThisWorkbook.Sheets(ss).Cells(c, "D") = 0
                        ThisWorkbook.Sheets(ss).Cells(c, "E") = 0
                    Else
                        ThisWorkbook.Sheets(ss).Cells(c, "B") = 0
                        ThisWorkbook.Sheets(ss).Cells(c, "C") = 0
                        ThisWorkbook.Sheets(ss).Cells(c, "D") = 1
                        ThisWorkbook.Sheets(ss).Cells(c, "E") = .Cells(b, "G")
                    End If
                    
                    ThisWorkbook.Sheets(ss).Cells(c, "F") = 1
                    ThisWorkbook.Sheets(ss).Cells(c, "G") = .Cells(b, "G")
                    f = 1
                    Exit For
                End If
                
                If ThisWorkbook.Sheets(ss).Cells(c, "A") = da Then
                    If InStr(1, .Cells(b, "D"), "男") > 0 Then
                        ThisWorkbook.Sheets(ss).Cells(c, "B") = ThisWorkbook.Sheets(ss).Cells(c, "B") + 1
                        ThisWorkbook.Sheets(ss).Cells(c, "C") = ThisWorkbook.Sheets(ss).Cells(c, "C") + .Cells(b, "G")
                    Else
                        ThisWorkbook.Sheets(ss).Cells(c, "D") = ThisWorkbook.Sheets(ss).Cells(c, "D") + 1
                        ThisWorkbook.Sheets(ss).Cells(c, "E") = ThisWorkbook.Sheets(ss).Cells(c, "E") + .Cells(b, "G")
                    End If
                    ThisWorkbook.Sheets(ss).Cells(c, "F") = ThisWorkbook.Sheets(ss).Cells(c, "F") + 1
                    ThisWorkbook.Sheets(ss).Cells(c, "G") = ThisWorkbook.Sheets(ss).Cells(c, "G") + .Cells(b, "G")
                    f = 1
                    Exit For
                End If
 
            Next c
            
            If f = 0 Then
                c = dd + 1
                ThisWorkbook.Sheets(ss).Cells(c, "A") = da
                
                If InStr(1, .Cells(b, "D"), "男") > 0 Then
                    ThisWorkbook.Sheets(ss).Cells(c, "B") = 1
                    ThisWorkbook.Sheets(ss).Cells(c, "C") = .Cells(b, "G")
                    ThisWorkbook.Sheets(ss).Cells(c, "D") = 0
                    ThisWorkbook.Sheets(ss).Cells(c, "E") = 0
                Else
                    ThisWorkbook.Sheets(ss).Cells(c, "B") = 0
                    ThisWorkbook.Sheets(ss).Cells(c, "C") = 0
                    ThisWorkbook.Sheets(ss).Cells(c, "D") = 1
                    ThisWorkbook.Sheets(ss).Cells(c, "E") = .Cells(b, "G")
                End If
                
                ThisWorkbook.Sheets(ss).Cells(c, "F") = 1
                ThisWorkbook.Sheets(ss).Cells(c, "G") = .Cells(b, "G")
            End If
            
            '正
            If .Cells(b, "G") >= 0 Then
                ss = "Sheet1"
            Else
            '負
                ss = "Sheet2"
            End If
            
            dd = ThisWorkbook.Sheets(ss).Range("G1").End(xlDown).Row
            If ThisWorkbook.Sheets(ss).Range("G2") = "" Then
                dd = 2
            End If
            
            f = 0
            For c = 2 To dd
                If ThisWorkbook.Sheets(ss).Cells(c, "A") = "" Then
                    ThisWorkbook.Sheets(ss).Cells(c, "A") = da
                    
                    If InStr(1, .Cells(b, "D"), "男") > 0 Then
                        ThisWorkbook.Sheets(ss).Cells(c, "B") = 1
                        ThisWorkbook.Sheets(ss).Cells(c, "C") = .Cells(b, "G")
                        ThisWorkbook.Sheets(ss).Cells(c, "D") = 0
                        ThisWorkbook.Sheets(ss).Cells(c, "E") = 0
                    Else
                        ThisWorkbook.Sheets(ss).Cells(c, "B") = 0
                        ThisWorkbook.Sheets(ss).Cells(c, "C") = 0
                        ThisWorkbook.Sheets(ss).Cells(c, "D") = 1
                        ThisWorkbook.Sheets(ss).Cells(c, "E") = .Cells(b, "G")
                    End If
                    
                    ThisWorkbook.Sheets(ss).Cells(c, "F") = 1
                    ThisWorkbook.Sheets(ss).Cells(c, "G") = .Cells(b, "G")
                    f = 1
                    Exit For
                End If
                
                If ThisWorkbook.Sheets(ss).Cells(c, "A") = da Then
                    If InStr(1, .Cells(b, "D"), "男") > 0 Then
                        ThisWorkbook.Sheets(ss).Cells(c, "B") = ThisWorkbook.Sheets(ss).Cells(c, "B") + 1
                        ThisWorkbook.Sheets(ss).Cells(c, "C") = ThisWorkbook.Sheets(ss).Cells(c, "C") + .Cells(b, "G")
                    Else
                        ThisWorkbook.Sheets(ss).Cells(c, "D") = ThisWorkbook.Sheets(ss).Cells(c, "D") + 1
                        ThisWorkbook.Sheets(ss).Cells(c, "E") = ThisWorkbook.Sheets(ss).Cells(c, "E") + .Cells(b, "G")
                    End If
                    ThisWorkbook.Sheets(ss).Cells(c, "F") = ThisWorkbook.Sheets(ss).Cells(c, "F") + 1
                    ThisWorkbook.Sheets(ss).Cells(c, "G") = ThisWorkbook.Sheets(ss).Cells(c, "G") + .Cells(b, "G")
                    f = 1
                    Exit For
                End If
 
            Next c
            
            If f = 0 Then
                c = dd + 1
                ThisWorkbook.Sheets(ss).Cells(c, "A") = da
                
                If InStr(1, .Cells(b, "D"), "男") > 0 Then
                    ThisWorkbook.Sheets(ss).Cells(c, "B") = 1
                    ThisWorkbook.Sheets(ss).Cells(c, "C") = .Cells(b, "G")
                    ThisWorkbook.Sheets(ss).Cells(c, "D") = 0
                    ThisWorkbook.Sheets(ss).Cells(c, "E") = 0
                Else
                    ThisWorkbook.Sheets(ss).Cells(c, "B") = 0
                    ThisWorkbook.Sheets(ss).Cells(c, "C") = 0
                    ThisWorkbook.Sheets(ss).Cells(c, "D") = 1
                    ThisWorkbook.Sheets(ss).Cells(c, "E") = .Cells(b, "G")
                End If
                
                ThisWorkbook.Sheets(ss).Cells(c, "F") = 1
                ThisWorkbook.Sheets(ss).Cells(c, "G") = .Cells(b, "G")
            End If
        
        Next b
        
    End With
    w.Close

    f = Dir
Loop

'合計算出
For a = 1 To 3
    Select Case a
        Case 1
             ss = "Sheet1"
        Case 2
             ss = "Sheet2"
        Case 3
             ss = "Sheet3"
    End Select

    With ThisWorkbook.Sheets(ss)
        dd = .Range("G1").End(xlDown).Row
        If a = 3 Then
            .Cells(dd + 1, "A") = "合計"
        Else
            .Cells(dd + 1, "A") = "計"
        End If
        
        .Cells(dd + 1, "B") = 0
        .Cells(dd + 1, "C") = 0
        .Cells(dd + 1, "D") = 0
        .Cells(dd + 1, "E") = 0
        .Cells(dd + 1, "F") = 0
        .Cells(dd + 1, "G") = 0
        For c = 2 To dd
            .Cells(dd + 1, "B") = .Cells(dd + 1, "B") + .Cells(c, "B")
            .Cells(dd + 1, "C") = .Cells(dd + 1, "C") + .Cells(c, "C")
            .Cells(dd + 1, "D") = .Cells(dd + 1, "D") + .Cells(c, "D")
            .Cells(dd + 1, "E") = .Cells(dd + 1, "E") + .Cells(c, "E")
            .Cells(dd + 1, "F") = .Cells(dd + 1, "F") + .Cells(c, "F")
            .Cells(dd + 1, "G") = .Cells(dd + 1, "G") + .Cells(c, "G")
        Next c
    End With
Next a
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 
id:inosisi4141

いつもお世話様です。

「引数が不正です」メッセージがでます

下記に変更しましたがよろしいでしょうか

頑張っていただいていますのでポイントは考慮します。

E列    F列    H列

性別   金額    日付

男    10,000  2011/5/1

女    -10,000  2011/5/1

2011/05/30 18:00:14
id:taknt No.2

きゃづみぃ回答回数13539ベストアンサー獲得回数11982011/05/30 18:46:06

ポイント33pt

多分 これでいいかな。

前回のは 日付の行を間違えてました。

Sub main()
Dim p As String

'集計対象シート初期化
    
ThisWorkbook.Sheets("Sheet1").Cells.Delete Shift:=xlUp
ThisWorkbook.Sheets("Sheet2").Cells.Delete Shift:=xlUp
ThisWorkbook.Sheets("Sheet3").Cells.Delete Shift:=xlUp


'見出しセット
ThisWorkbook.Sheets("Sheet1").Range("B1") = "男性"
ThisWorkbook.Sheets("Sheet1").Range("C1") = "金額計"
ThisWorkbook.Sheets("Sheet1").Range("D1") = "女性"
ThisWorkbook.Sheets("Sheet1").Range("E1") = "金額計"
ThisWorkbook.Sheets("Sheet1").Range("F1") = "男女計"
ThisWorkbook.Sheets("Sheet1").Range("G1") = "金額合計"

ThisWorkbook.Sheets("Sheet2").Range("B1") = "男性"
ThisWorkbook.Sheets("Sheet2").Range("C1") = "金額計"
ThisWorkbook.Sheets("Sheet2").Range("D1") = "女性"
ThisWorkbook.Sheets("Sheet2").Range("E1") = "金額計"
ThisWorkbook.Sheets("Sheet2").Range("F1") = "男女計"
ThisWorkbook.Sheets("Sheet2").Range("G1") = "金額合計"

ThisWorkbook.Sheets("Sheet3").Range("B1") = "男性"
ThisWorkbook.Sheets("Sheet3").Range("C1") = "金額計"
ThisWorkbook.Sheets("Sheet3").Range("D1") = "女性"
ThisWorkbook.Sheets("Sheet3").Range("E1") = "金額計"
ThisWorkbook.Sheets("Sheet3").Range("F1") = "男女計"
ThisWorkbook.Sheets("Sheet3").Range("G1") = "金額合計"


'対象フォルダを指定してください。
'このフォルダに この実行用のブックは 入れないでください。
p = "C:\test\"

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

End Sub


Sub jikkou(p As String, s As String)

Dim bk As Workbook
Dim b1 As String
Dim ab As String

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 = "D"        'チェックする列
        
        For b = kg To .Cells(kg, ck).End(xlDown).Row
            
            da = .Cells(b, "J")
            If Len(da) >= 8 Then
                aa = InStr(1, da, " ")
                ab = Left(da, aa - 1)
                da = Convert_Date(ab)
            End If
            
            '計
            ss = "Sheet3"
            dd = ThisWorkbook.Sheets(ss).Range("G1").End(xlDown).Row
            If ThisWorkbook.Sheets(ss).Range("G2") = "" Then
                dd = 2
            End If
            
            f = 0
            For c = 2 To dd
                If ThisWorkbook.Sheets(ss).Cells(c, "A") = "" Then
                    ThisWorkbook.Sheets(ss).Cells(c, "A") = da
                    
                    If InStr(1, .Cells(b, "E"), "男") > 0 Then
                        ThisWorkbook.Sheets(ss).Cells(c, "B") = 1
                        ThisWorkbook.Sheets(ss).Cells(c, "C") = .Cells(b, "F")
                        ThisWorkbook.Sheets(ss).Cells(c, "D") = 0
                        ThisWorkbook.Sheets(ss).Cells(c, "E") = 0
                    Else
                        ThisWorkbook.Sheets(ss).Cells(c, "B") = 0
                        ThisWorkbook.Sheets(ss).Cells(c, "C") = 0
                        ThisWorkbook.Sheets(ss).Cells(c, "D") = 1
                        ThisWorkbook.Sheets(ss).Cells(c, "E") = .Cells(b, "F")
                    End If
                    
                    ThisWorkbook.Sheets(ss).Cells(c, "F") = 1
                    ThisWorkbook.Sheets(ss).Cells(c, "G") = .Cells(b, "F")
                    f = 1
                    Exit For
                End If
                
                If ThisWorkbook.Sheets(ss).Cells(c, "A") = da Then
                    If InStr(1, .Cells(b, "E"), "男") > 0 Then
                        ThisWorkbook.Sheets(ss).Cells(c, "B") = ThisWorkbook.Sheets(ss).Cells(c, "B") + 1
                        ThisWorkbook.Sheets(ss).Cells(c, "C") = ThisWorkbook.Sheets(ss).Cells(c, "C") + .Cells(b, "F")
                    Else
                        ThisWorkbook.Sheets(ss).Cells(c, "D") = ThisWorkbook.Sheets(ss).Cells(c, "D") + 1
                        ThisWorkbook.Sheets(ss).Cells(c, "E") = ThisWorkbook.Sheets(ss).Cells(c, "E") + .Cells(b, "F")
                    End If
                    ThisWorkbook.Sheets(ss).Cells(c, "F") = ThisWorkbook.Sheets(ss).Cells(c, "F") + 1
                    ThisWorkbook.Sheets(ss).Cells(c, "G") = ThisWorkbook.Sheets(ss).Cells(c, "G") + .Cells(b, "F")
                    f = 1
                    Exit For
                End If
 
            Next c
            
            If f = 0 Then
                c = dd + 1
                ThisWorkbook.Sheets(ss).Cells(c, "A") = da
                
                If InStr(1, .Cells(b, "E"), "男") > 0 Then
                    ThisWorkbook.Sheets(ss).Cells(c, "B") = 1
                    ThisWorkbook.Sheets(ss).Cells(c, "C") = .Cells(b, "F")
                    ThisWorkbook.Sheets(ss).Cells(c, "D") = 0
                    ThisWorkbook.Sheets(ss).Cells(c, "E") = 0
                Else
                    ThisWorkbook.Sheets(ss).Cells(c, "B") = 0
                    ThisWorkbook.Sheets(ss).Cells(c, "C") = 0
                    ThisWorkbook.Sheets(ss).Cells(c, "D") = 1
                    ThisWorkbook.Sheets(ss).Cells(c, "E") = .Cells(b, "F")
                End If
                
                ThisWorkbook.Sheets(ss).Cells(c, "F") = 1
                ThisWorkbook.Sheets(ss).Cells(c, "G") = .Cells(b, "F")
            End If
            
            '正
            If .Cells(b, "F") >= 0 Then
                ss = "Sheet1"
            Else
            '負
                ss = "Sheet2"
            End If
            
            dd = ThisWorkbook.Sheets(ss).Range("G1").End(xlDown).Row
            If ThisWorkbook.Sheets(ss).Range("G2") = "" Then
                dd = 2
            End If
            
            f = 0
            For c = 2 To dd
                If ThisWorkbook.Sheets(ss).Cells(c, "A") = "" Then
                    ThisWorkbook.Sheets(ss).Cells(c, "A") = da
                    
                    If InStr(1, .Cells(b, "E"), "男") > 0 Then
                        ThisWorkbook.Sheets(ss).Cells(c, "B") = 1
                        ThisWorkbook.Sheets(ss).Cells(c, "C") = .Cells(b, "F")
                        ThisWorkbook.Sheets(ss).Cells(c, "D") = 0
                        ThisWorkbook.Sheets(ss).Cells(c, "E") = 0
                    Else
                        ThisWorkbook.Sheets(ss).Cells(c, "B") = 0
                        ThisWorkbook.Sheets(ss).Cells(c, "C") = 0
                        ThisWorkbook.Sheets(ss).Cells(c, "D") = 1
                        ThisWorkbook.Sheets(ss).Cells(c, "E") = .Cells(b, "F")
                    End If
                    
                    ThisWorkbook.Sheets(ss).Cells(c, "F") = 1
                    ThisWorkbook.Sheets(ss).Cells(c, "G") = .Cells(b, "F")
                    f = 1
                    Exit For
                End If
                
                If ThisWorkbook.Sheets(ss).Cells(c, "A") = da Then
                    If InStr(1, .Cells(b, "E"), "男") > 0 Then
                        ThisWorkbook.Sheets(ss).Cells(c, "B") = ThisWorkbook.Sheets(ss).Cells(c, "B") + 1
                        ThisWorkbook.Sheets(ss).Cells(c, "C") = ThisWorkbook.Sheets(ss).Cells(c, "C") + .Cells(b, "F")
                    Else
                        ThisWorkbook.Sheets(ss).Cells(c, "D") = ThisWorkbook.Sheets(ss).Cells(c, "D") + 1
                        ThisWorkbook.Sheets(ss).Cells(c, "E") = ThisWorkbook.Sheets(ss).Cells(c, "E") + .Cells(b, "F")
                    End If
                    ThisWorkbook.Sheets(ss).Cells(c, "F") = ThisWorkbook.Sheets(ss).Cells(c, "F") + 1
                    ThisWorkbook.Sheets(ss).Cells(c, "G") = ThisWorkbook.Sheets(ss).Cells(c, "G") + .Cells(b, "F")
                    f = 1
                    Exit For
                End If
 
            Next c
            
            If f = 0 Then
                c = dd + 1
                ThisWorkbook.Sheets(ss).Cells(c, "A") = da
                
                If InStr(1, .Cells(b, "E"), "男") > 0 Then
                    ThisWorkbook.Sheets(ss).Cells(c, "B") = 1
                    ThisWorkbook.Sheets(ss).Cells(c, "C") = .Cells(b, "F")
                    ThisWorkbook.Sheets(ss).Cells(c, "D") = 0
                    ThisWorkbook.Sheets(ss).Cells(c, "E") = 0
                Else
                    ThisWorkbook.Sheets(ss).Cells(c, "B") = 0
                    ThisWorkbook.Sheets(ss).Cells(c, "C") = 0
                    ThisWorkbook.Sheets(ss).Cells(c, "D") = 1
                    ThisWorkbook.Sheets(ss).Cells(c, "E") = .Cells(b, "F")
                End If
                
                ThisWorkbook.Sheets(ss).Cells(c, "F") = 1
                ThisWorkbook.Sheets(ss).Cells(c, "G") = .Cells(b, "F")
            End If
        
        Next b
        
    End With
    w.Close

    f = Dir
Loop

'合計算出
For a = 1 To 3
    Select Case a
        Case 1
             ss = "Sheet1"
        Case 2
             ss = "Sheet2"
        Case 3
             ss = "Sheet3"
    End Select

    With ThisWorkbook.Sheets(ss)
        dd = .Range("G1").End(xlDown).Row
        If a = 3 Then
            .Cells(dd + 1, "A") = "合計"
        Else
            .Cells(dd + 1, "A") = "計"
        End If
        
        .Cells(dd + 1, "B") = 0
        .Cells(dd + 1, "C") = 0
        .Cells(dd + 1, "D") = 0
        .Cells(dd + 1, "E") = 0
        .Cells(dd + 1, "F") = 0
        .Cells(dd + 1, "G") = 0
        For c = 2 To dd
            .Cells(dd + 1, "B") = .Cells(dd + 1, "B") + .Cells(c, "B")
            .Cells(dd + 1, "C") = .Cells(dd + 1, "C") + .Cells(c, "C")
            .Cells(dd + 1, "D") = .Cells(dd + 1, "D") + .Cells(c, "D")
            .Cells(dd + 1, "E") = .Cells(dd + 1, "E") + .Cells(c, "E")
            .Cells(dd + 1, "F") = .Cells(dd + 1, "F") + .Cells(c, "F")
            .Cells(dd + 1, "G") = .Cells(dd + 1, "G") + .Cells(c, "G")
        Next c
    End With
Next a
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 + 
id:taknt No.3

きゃづみぃ回答回数13539ベストアンサー獲得回数11982011/05/30 19:23:40ここでベストアンサー

ポイント33pt

Function Convert_Date(a As String) As Date 以降が 入りきれてなかったので

入れなおしてください。

文字数制限で ソースが 長すぎて ダメだったようです。

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

    エクセルでE列に男女の性別、F列に金額(正数と負数)、H列に日付
    のデータがあります。データは2行目からです。
    データはCSVファイルをc\test\に置いて
    別ファイルSheet1に正数の答え、Sheet2に負数の答え、Sheet3に正負合計の結果一覧を作成するマクロをお願いします。
    c\test\のエクセルCSVデータ
    E列   F列   H列
    性別  金額   日付
    女  -10,000  2011/5/1

    答えの一覧表は
    Sheet1に正数の一覧集計
    Sheet2に負数の一覧集計
    Sheet3にその合計の一覧集計
    の3個の一覧表
    各sheetに日付ごとに男女別の男女の人数と金額の集計表を作成。
    項目名はこちらで入力します。答えは2行目からおねがいします。
    画像を添付しておりますので参照おねがいします。質問データの列位置変更



    E列   F列    H列
    性別   金額   日付

    に変更おねがいします。
  • id:taknt
    エラーは 変更前で 出るんですか?
  • id:inosisi4141

    別なPCでテストしましたら

    コンパイルエラー
    で最上部と最下部の文字に色がついています

    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
  • id:inosisi4141
    takntさん

    日付をソートして

    マクロを実行すると

    プロジャーの呼び出し、または引数が不正です

    のエラーがでて

    CSVファイルを呼び出してきます。
  • id:inosisi4141
    takntさん

    E列   F列    H列
    性別   金額   日付
    に変更後にでます。
  • id:inosisi4141
    takntさん

    E列   F列    H列
    性別   金額   日付
    に変更後にでます。
  • id:inosisi4141
    takntさん

    変更前の
    D列G列J列ではエラーは出ませんが
    結果の答えが
    sheet1
    男性 金額計 女性 金額計 男女計 金額合計
    1 3000 0 0 1 3000
    計 1 3000 0 0 1 3000

    sheet2
    男性 金額計 女性 金額計 男女計 金額合計
    0 0 1 -10000 1 -10000
    計 0 0 1 -10000 1 -10000

    sheet3
    男性 金額計 女性 金額計 男女計 金額合計
    1 3000 0 0 1 3000
    合計 1 3000 0 0 1 3000

    の結果です
    日付ごとの表示がでません。
    よろしくお願いします
  • id:taknt
    一応 念のため 貼りなおしてみます。
    Sub main()
    Dim p As String

    '集計対象シート初期化

    ThisWorkbook.Sheets("Sheet1").Cells.Delete Shift:=xlUp
    ThisWorkbook.Sheets("Sheet2").Cells.Delete Shift:=xlUp
    ThisWorkbook.Sheets("Sheet3").Cells.Delete Shift:=xlUp


    '見出しセット
    ThisWorkbook.Sheets("Sheet1").Range("B1") = "男性"
    ThisWorkbook.Sheets("Sheet1").Range("C1") = "金額計"
    ThisWorkbook.Sheets("Sheet1").Range("D1") = "女性"
    ThisWorkbook.Sheets("Sheet1").Range("E1") = "金額計"
    ThisWorkbook.Sheets("Sheet1").Range("F1") = "男女計"
    ThisWorkbook.Sheets("Sheet1").Range("G1") = "金額合計"

    ThisWorkbook.Sheets("Sheet2").Range("B1") = "男性"
    ThisWorkbook.Sheets("Sheet2").Range("C1") = "金額計"
    ThisWorkbook.Sheets("Sheet2").Range("D1") = "女性"
    ThisWorkbook.Sheets("Sheet2").Range("E1") = "金額計"
    ThisWorkbook.Sheets("Sheet2").Range("F1") = "男女計"
    ThisWorkbook.Sheets("Sheet2").Range("G1") = "金額合計"

    ThisWorkbook.Sheets("Sheet3").Range("B1") = "男性"
    ThisWorkbook.Sheets("Sheet3").Range("C1") = "金額計"
    ThisWorkbook.Sheets("Sheet3").Range("D1") = "女性"
    ThisWorkbook.Sheets("Sheet3").Range("E1") = "金額計"
    ThisWorkbook.Sheets("Sheet3").Range("F1") = "男女計"
    ThisWorkbook.Sheets("Sheet3").Range("G1") = "金額合計"


    '対象フォルダを指定してください。
    'このフォルダに この実行用のブックは 入れないでください。
    p = "C:\test\"

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

    End Sub


    Sub jikkou(p As String, s As String)

    Dim bk As Workbook
    Dim b1 As String
    Dim ab As String

    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 = "D" 'チェックする列

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

    da = .Cells(b, "J")
    If Len(da) >= 8 Then
    aa = InStr(1, da, " ")
    ab = Left(da, aa - 1)
    da = Convert_Date(ab)
    End If

    '計
    ss = "Sheet3"
    dd = ThisWorkbook.Sheets(ss).Range("G1").End(xlDown).Row
    If ThisWorkbook.Sheets(ss).Range("G2") = "" Then
    dd = 2
    End If

    f = 0
    For c = 2 To dd
    If ThisWorkbook.Sheets(ss).Cells(c, "A") = "" Then
    ThisWorkbook.Sheets(ss).Cells(c, "A") = da

    If InStr(1, .Cells(b, "E"), "男") > 0 Then
    ThisWorkbook.Sheets(ss).Cells(c, "B") = 1
    ThisWorkbook.Sheets(ss).Cells(c, "C") = .Cells(b, "F")
    ThisWorkbook.Sheets(ss).Cells(c, "D") = 0
    ThisWorkbook.Sheets(ss).Cells(c, "E") = 0
    Else
    ThisWorkbook.Sheets(ss).Cells(c, "B") = 0
    ThisWorkbook.Sheets(ss).Cells(c, "C") = 0
    ThisWorkbook.Sheets(ss).Cells(c, "D") = 1
    ThisWorkbook.Sheets(ss).Cells(c, "E") = .Cells(b, "F")
    End If

    ThisWorkbook.Sheets(ss).Cells(c, "F") = 1
    ThisWorkbook.Sheets(ss).Cells(c, "G") = .Cells(b, "F")
    f = 1
    Exit For
    End If

    If ThisWorkbook.Sheets(ss).Cells(c, "A") = da Then
    If InStr(1, .Cells(b, "E"), "男") > 0 Then
    ThisWorkbook.Sheets(ss).Cells(c, "B") = ThisWorkbook.Sheets(ss).Cells(c, "B") + 1
    ThisWorkbook.Sheets(ss).Cells(c, "C") = ThisWorkbook.Sheets(ss).Cells(c, "C") + .Cells(b, "F")
    Else
    ThisWorkbook.Sheets(ss).Cells(c, "D") = ThisWorkbook.Sheets(ss).Cells(c, "D") + 1
    ThisWorkbook.Sheets(ss).Cells(c, "E") = ThisWorkbook.Sheets(ss).Cells(c, "E") + .Cells(b, "F")
    End If
    ThisWorkbook.Sheets(ss).Cells(c, "F") = ThisWorkbook.Sheets(ss).Cells(c, "F") + 1
    ThisWorkbook.Sheets(ss).Cells(c, "G") = ThisWorkbook.Sheets(ss).Cells(c, "G") + .Cells(b, "F")
    f = 1
    Exit For
    End If

    Next c

    If f = 0 Then
    c = dd + 1
    ThisWorkbook.Sheets(ss).Cells(c, "A") = da

    If InStr(1, .Cells(b, "E"), "男") > 0 Then
    ThisWorkbook.Sheets(ss).Cells(c, "B") = 1
    ThisWorkbook.Sheets(ss).Cells(c, "C") = .Cells(b, "F")
    ThisWorkbook.Sheets(ss).Cells(c, "D") = 0
    ThisWorkbook.Sheets(ss).Cells(c, "E") = 0
    Else
    ThisWorkbook.Sheets(ss).Cells(c, "B") = 0
    ThisWorkbook.Sheets(ss).Cells(c, "C") = 0
    ThisWorkbook.Sheets(ss).Cells(c, "D") = 1
    ThisWorkbook.Sheets(ss).Cells(c, "E") = .Cells(b, "F")
    End If

    ThisWorkbook.Sheets(ss).Cells(c, "F") = 1
    ThisWorkbook.Sheets(ss).Cells(c, "G") = .Cells(b, "F")
    End If

    '正
    If .Cells(b, "F") >= 0 Then
    ss = "Sheet1"
    Else
    '負
    ss = "Sheet2"
    End If

    dd = ThisWorkbook.Sheets(ss).Range("G1").End(xlDown).Row
    If ThisWorkbook.Sheets(ss).Range("G2") = "" Then
    dd = 2
    End If

    f = 0
    For c = 2 To dd
    If ThisWorkbook.Sheets(ss).Cells(c, "A") = "" Then
    ThisWorkbook.Sheets(ss).Cells(c, "A") = da

    If InStr(1, .Cells(b, "E"), "男") > 0 Then
    ThisWorkbook.Sheets(ss).Cells(c, "B") = 1
    ThisWorkbook.Sheets(ss).Cells(c, "C") = .Cells(b, "F")
    ThisWorkbook.Sheets(ss).Cells(c, "D") = 0
    ThisWorkbook.Sheets(ss).Cells(c, "E") = 0
    Else
    ThisWorkbook.Sheets(ss).Cells(c, "B") = 0
    ThisWorkbook.Sheets(ss).Cells(c, "C") = 0
    ThisWorkbook.Sheets(ss).Cells(c, "D") = 1
    ThisWorkbook.Sheets(ss).Cells(c, "E") = .Cells(b, "F")
    End If

    ThisWorkbook.Sheets(ss).Cells(c, "F") = 1
    ThisWorkbook.Sheets(ss).Cells(c, "G") = .Cells(b, "F")
    f = 1
    Exit For
    End If

    If ThisWorkbook.Sheets(ss).Cells(c, "A") = da Then
    If InStr(1, .Cells(b, "E"), "男") > 0 Then
    ThisWorkbook.Sheets(ss).Cells(c, "B") = ThisWorkbook.Sheets(ss).Cells(c, "B") + 1
    ThisWorkbook.Sheets(ss).Cells(c, "C") = ThisWorkbook.Sheets(ss).Cells(c, "C") + .Cells(b, "F")
    Else
    ThisWorkbook.Sheets(ss).Cells(c, "D") = ThisWorkbook.Sheets(ss).Cells(c, "D") + 1
    ThisWorkbook.Sheets(ss).Cells(c, "E") = ThisWorkbook.Sheets(ss).Cells(c, "E") + .Cells(b, "F")
    End If
    ThisWorkbook.Sheets(ss).Cells(c, "F") = ThisWorkbook.Sheets(ss).Cells(c, "F") + 1
    ThisWorkbook.Sheets(ss).Cells(c, "G") = ThisWorkbook.Sheets(ss).Cells(c, "G") + .Cells(b, "F")
    f = 1
    Exit For
    End If

    Next c

    If f = 0 Then
    c = dd + 1
    ThisWorkbook.Sheets(ss).Cells(c, "A") = da

    If InStr(1, .Cells(b, "E"), "男") > 0 Then
    ThisWorkbook.Sheets(ss).Cells(c, "B") = 1
    ThisWorkbook.Sheets(ss).Cells(c, "C") = .Cells(b, "F")
    ThisWorkbook.Sheets(ss).Cells(c, "D") = 0
    ThisWorkbook.Sheets(ss).Cells(c, "E") = 0
    Else
    ThisWorkbook.Sheets(ss).Cells(c, "B") = 0
    ThisWorkbook.Sheets(ss).Cells(c, "C") = 0
    ThisWorkbook.Sheets(ss).Cells(c, "D") = 1
    ThisWorkbook.Sheets(ss).Cells(c, "E") = .Cells(b, "F")
    End If

    ThisWorkbook.Sheets(ss).Cells(c, "F") = 1
    ThisWorkbook.Sheets(ss).Cells(c, "G") = .Cells(b, "F")
    End If

    Next b

    End With
    w.Close

    f = Dir
    Loop

    '合計算出
    For a = 1 To 3
    Select Case a
    Case 1
    ss = "Sheet1"
    Case 2
    ss = "Sheet2"
    Case 3
    ss = "Sheet3"
    End Select

    With ThisWorkbook.Sheets(ss)
    dd = .Range("G1").End(xlDown).Row
    If a = 3 Then
    .Cells(dd + 1, "A") = "合計"
    Else
    .Cells(dd + 1, "A") = "計"
    End If

    .Cells(dd + 1, "B") = 0
    .Cells(dd + 1, "C") = 0
    .Cells(dd + 1, "D") = 0
    .Cells(dd + 1, "E") = 0
    .Cells(dd + 1, "F") = 0
    .Cells(dd + 1, "G") = 0
    For c = 2 To dd
    .Cells(dd + 1, "B") = .Cells(dd + 1, "B") + .Cells(c, "B")
    .Cells(dd + 1, "C") = .Cells(dd + 1, "C") + .Cells(c, "C")
    .Cells(dd + 1, "D") = .Cells(dd + 1, "D") + .Cells(c, "D")
    .Cells(dd + 1, "E") = .Cells(dd + 1, "E") + .Cells(c, "E")
    .Cells(dd + 1, "F") = .Cells(dd + 1, "F") + .Cells(c, "F")
    .Cells(dd + 1, "G") = .Cells(dd + 1, "G") + .Cells(c, "G")
    Next c
    End With
    Next a
    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
    お手数お掛けします

    日付をやっぱり表示しません
    金額を1行に合計しているみたいです。


    男性 金額計 女性 金額計 男女計 金額合計
    12:00:00 AM 759 7433498 230 2578000 989 10011498
       計  759 7433498 230 2578000 989 10011498
  • id:taknt
    12:00:00 AM となるのは 日付が 0000-00-00 とかのやつですね。
    つまり 0のものです。

    da = .Cells(b, "J")

    da = .Cells(b, "H")
    に変えてください。
  • id:inosisi4141
    takntさん
    ありがとうございます。
    うまく行きました。完璧です。

    再質問しますので正式なソース回答を貼ってください。
    今後ともよろしくお願いします。

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

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

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

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