昨日のつづき

頂き物にちょこちょこ手を加えてとりあえず動くようになりました。

Sub CSVtoXLSandCalc()

''XL97,XL2000で確認済み　by 渡辺ひかる　 -Last Update-2002/12/24-13:01
Dim myFS As FileSearch
Dim mySvWb As Workbook
Dim i As Long
Dim ChDir As Variant


ChDir = InputBox("CSVファイルの入っているフォルダのフルパスを入力してください。")
Set myFS = Application.FileSearch
With myFS
.LookIn = ChDir
.Filename = "*.csv"
If .Execute > 0 Then
'保存用ブックを追加
Workbooks.Add
Set mySvWb = Workbooks(2)
For i = 1 To .FoundFiles.Count
'見つかったファイルを一つずつ開く
'（オプションは適宜変更してください）
Workbooks.OpenText Filename:=.FoundFiles(i), _
StartRow:=1, _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Comma:=True
'保存用ブックに移動
Sheets(1).Move After:=mySvWb.Worksheets(mySvWb.Sheets.Count)
'元のファイルを削除(適宜）
'Kill .FoundFiles(I)
Next i
'初期設定のシートを削除
Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
'保存用ブックを保存して閉じる
'mySvWb.SaveAs Filename:="CSV_hozon"
'mySvWb.Close
Else
'検索結果が０なら
MsgBox "検索条件を満たすファイルはありません。"
End If
End With



Worksheets.Add
With ActiveSheet
.Name = "集計"
.Range("B1").Value = "hoge"
.Range("C1").Value = "hogeho"
.Range("D1").Value = "hogehoge"
End With

Columns("B:D").AutoFit
Columns("A:A").ColumnWidth = 15
For i = 2 To Application.Sheets.Count

ActiveSheet.Range("A" & i).Value = Application.Sheets(i).Range("A1").Value
ActiveSheet.Range("B" & i).Value = Application.Sheets(i).Range("B27").Value
ActiveSheet.Range("C" & i).Value = Application.Sheets(i).Range("D27").Value
ActiveSheet.Range("D" & i).Value = Application.Sheets(i).Range("E27").Value

'MsgBox Application.Sheets(i).Range("A1").Value
Next
bName = Mid(Application.Sheets(2).Name, 4, 4) & "年" & Mid(Application.Sheets(2).Name, 8, 2) & "月分"
mySvWb.SaveAs Filename:=ChDir & bName
End Sub

なんとも知性のかけらもないコードっすorz

でも、JavaScriptをかじってただけでもリファレンス＆サンプルを見るだけで
とりあえずは動くもんですね（汗）

結構、ExcelVBAも楽しいかも。

ひとりごと

この前から思ってたんだけど、引用文の中にコードを書いてますが、
インデントとか折り返しとかってどうやって調整するんだろ。
実際のコードとブログに上げたものとの差が・・・。

そうでなくても汚コードがより汚コードに・・・