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

質問です。
エクセルで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行目からおねがいします。
画像を添付しておりますので参照おねがいします。

1306735390
●拡大する


●質問者: inosisi
●カテゴリ:コンピュータ インターネット
✍キーワード:CSV test と金 エクセル データ
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

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

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

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 
◎質問者からの返答

いつもお世話様です。

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

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

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

E列 F列 H列

性別 金額 日付

男 10,000 2011/5/1

女 -10,000 2011/5/1


2 ● きゃづみぃ
●33ポイント

多分 これでいいかな。

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

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 + 


3 ● きゃづみぃ
●33ポイント ベストアンサー

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
関連質問


●質問をもっと探す●



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