Option Explicit
'概要 CSVを読込、対象月（工期Ｅ）以降のシートを作成しCSVの内容を編集する。
'2015/03/13 Ver 1.0.0 リリース
Dim strMsg As String
Dim strStyle As String
Const conTITLE = "工事情報取込処理"
Dim strYM As String
'ＣＳＶ取込ボタン
Sub impData()
Dim i As Long
Dim strCsvFile As String
'On Error GoTo ErrHandler
Application.ScreenUpdating = False '画面描写を止める
'CSVファイル取込み
strCsvFile = comDlgOpen
If strCsvFile = "" Then
strMsg = "ファイルを選択して下さい。"
GoTo ErrHandler
End If
strYM = Mid(Dir(strCsvFile), 8, 6) '対象月
'シート削除
Dim mySheet As Worksheet
Application.DisplayAlerts = False
For Each mySheet In Worksheets
If mySheet.name = "main" Or mySheet.name = "csv" Or mySheet.name < strYM Then
Else
Worksheets(mySheet.name).Delete
End If
Next
Application.DisplayAlerts = True
'オートフィルタを解除する
If ActiveSheet.AutoFilterMode Then
ActiveSheet.AutoFilterMode = False
End If
Sheets("csv").Select
Call getCsv(strCsvFile) 'ＣＳＶ取込
Call srtXls 'ソート処理
ActiveSheet.Range("A1").AutoFilter 'オートフィルタ設定する
Call addData 'データ追加
For Each mySheet In Worksheets 'シート整形
If mySheet.name = "main" Or mySheet.name < strYM Then
Else
Sheets(mySheet.name).Select
Cells.EntireColumn.AutoFit
Cells(1, 1).Select
End If
Next
Sheets("main").Select
Cells(1, 1).Select
Application.ScreenUpdating = True '画面描写を初期化
strMsg = "処理が完了しました。"
strStyle = vbOKOnly + vbInformation
MsgBox strMsg, strStyle, conTITLE
Exit Sub
ErrHandler:
If strMsg = "" Then
strMsg = "Error No =" & Err.Number & vbNewLine & "Error Msg=" & Err.Description
End If
strStyle = vbOKOnly + vbCritical
MsgBox strMsg, strStyle, conTITLE
End Sub
'データ追加
Sub addData()
'On Error GoTo ErrHandler
Dim strSheets As String
Dim lonXlsRow As Long
Dim i As Long
Dim j As Long
For lonXlsRow = 2 To Range("A1").End(xlDown).Row
'DoEvents
If Cells(lonXlsRow, 1) <> "" Then
strSheets = Replace(Left(Cells(lonXlsRow, 17), 7), "/", "")
If strYM <= strSheets Then
If ExistsWorksheet(strSheets) = False Then
'シートなし
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.name = strSheets
Sheets("csv").Select
For i = 1 To 78
Sheets(strSheets).Cells(1, i) = Cells(1, i)
Next i
End If
j = Sheets(strSheets).Cells(Rows.Count, 1).End(xlUp).Row + 1
'明細
For i = 1 To 78
Sheets(strSheets).Cells(j, i) = Cells(lonXlsRow, i)
Next i
End If
End If
Next lonXlsRow
Exit Sub
ErrHandler:
strStyle = vbOKOnly + vbCritical
MsgBox strMsg, strStyle, conTITLE
End Sub
'シートの存在確認
Function ExistsWorksheet(ByVal name As String) As Boolean
Dim mySheet As Worksheet
For Each mySheet In Sheets
If mySheet.name = name Then
ExistsWorksheet = True '存在する
Exit Function
End If
Next
'存在しない
ExistsWorksheet = False
End Function
'ＣＳＶ取込
Sub getCsv(ByVal strCsvFile As String)
'TextFileColumnDataTypes生成
' Dim strArray As String
' Dim i As Integer
' strArray = ""
' For i = 1 To 78
' strArray = strArray & "2,"
' Next i
' strArray = Left(strArray, Len(strArray) - 1)
Cells.Select
Selection.Delete Shift:=xlUp
With ActiveSheet.QueryTables.Add(Connection:="text;" & strCsvFile, Destination:=Range("A1"))
.name = "linkName"
.TextFileCommaDelimiter = True
.TextFilePlatform = 932
.TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)
.Refresh
End With
'オブジェクト削除
Call clsAllNames
End Sub
'ソート処理
Sub srtXls()
Range("A1:A" & Range("A1").End(xlDown).Row).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Sort Key1:=Range("Q2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin, DataOption1:=xlSortTextAsNumbers
End Sub
'オブジェクト削除
Sub clsAllNames()
Dim objName As name
For Each objName In ActiveWorkbook.Names
objName.Delete
Next objName
End Sub
'ファイル選択ダイアログ表示
Function comDlgOpen() As String
Dim varFile As Variant
comDlgOpen = ""
varFile = Application.GetOpenFilename("Csv ファイル (*.csv),*.csv")
If VarType(varFile) = vbBoolean Then
comDlgOpen = ""
Else
comDlgOpen = varFile
End If
End Function
'終了ボタン
Sub xlsEnd()
On Error Resume Next
'ActiveWorkbook.Saved = True '保存せずに終了
ThisWorkbook.Close SaveChanges:=False
'Application.Quit 'EXCEL終了
End Sub