EXCEL超初心者マクロ（5）－追加でcsvを取り込みたいとき－

2018年5月30日2018年10月4日

以前csv取り込みのサンプルをUPしましたが、今回はcsvを追加で取込むマクロを紹介します。
複数のcsvファイルを取込むときに使えると思います。

取込む位置を決めて、そこに追加していくやりかたです。
【条件】基準項目は必ず存在する。

以下マクロの内容です。

MSG_FLG = MsgBox("サンプルファイル" &amp; vbCrLf &amp; "★追加　取込み処理実行ＯＫ？", vbYesNo)
If MSG_FLG = vbNo Then
   Exit Sub
End If

Const cnsTITLE = "○SAMPLEデータ、取込み処理"
Const cnsFILTER = "SAMPLE csvファイル (*.csv),*.csv"

' ***対象シートセット***
'
Dim vFILENAME As Variant ' OPENするファイル名(フルパス)

With CreateObject("WScript.Shell")
.CurrentDirectory = Worksheets("KANRI").Range("B2")
End With

Sheets("DATA").Select
Range("A1").Select

If Worksheets("DATA").Range("A1") = "" Then
   '### 新規（空のとき）　****
   Application.StatusBar = "初回"
   WK_START01 = "A1"
Else
   '### 追加とき　****
   MAXLOW1 = Cells(Rows.Count, 1).End(xlUp).Row
   ’対象列（この場合1列目）の一番下の位置を取得します。

   Set set_data01 = Worksheets("DATA").Range("A1")
   '...取込むシートのA1をセット

   Set set_data01 = set_data01.Offset(MAXLOW1, 0)
   '...A1からMAXLOW1分だけ下に移動

   WK_START01 = set_data01.Address(RowAbsolute:=False, ColumnAbsolute:=False)
   '...今いる位置をWK_START01へセット...AAA

End If
MsgBox ("取り込み位置： " & WK_START01)

vFILENAME = Application.GetOpenFilename(FileFilter:=cnsFILTER, title:=cnsTITLE)
If VarType(vFILENAME) = vbBoolean Then
   MsgBox ("キャンセル")
   Exit Sub
End If

With ActiveSheet.QueryTables.Add(Connection:= "TEXT;" & vFILENAME, Destination:=ActiveSheet.Range(WK_START01))
’...AAAの位置から追加（以下通常取込みと一緒）

''...省略...
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 932
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(2, 2, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With

Range("A1").Select

MSG_FLG = MsgBox("取り込み終了" &amp; vbCrLf &amp; vbCrLf &amp; "(^^)")

Application.StatusBar = "追加 取込み終了"

VBA（マクロ）,SAMPLE付

Posted by master