CSVを取り込む その2
Dim FileN
Dim shTHIS As Worksheet
Dim tmp
Dim strBuf
Dim clm
'取り込むファイルをダイアログで選択、キャンセルで中断
FileN = Application.GetOpenFilename("CSVファイル,*.csv")
If FileN = False Then Exit Sub
'取り込み先のシートを指定
Set shTHIS = ThisWorkbook.Worksheets("シート名")
shTHIS.Cells.Clear
'対象ファイルのフィールド数を特定する
Open FileN For Input As #1
Line Input #1, strBuf
tmp = Split(strBuf, ",")
ReDim clm(UBound(tmp))
For i = 0 To UBound(tmp)
clm(i) = 2
Next i
Close #1
'外部データ取込機能で取り込む、貼り付け位置はDestinationで指定
With shTHIS.QueryTables.Add(Connection:="TEXT;" & FileN, Destination:=shTHIS.Range("$A$1"))
.TextFilePlatform = 932
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileCommaDelimiter = True
.TextFileColumnDataTypes = clm
.AdjustColumnWidth = False
.RefreshStyle = xlOverwriteCells
.Refresh
.Delete
End With
Open For Inputだと引用符(")の扱いで難しいのでQuertTablesで取り込むコード。
Excelの外部データ取り込み機能が基。
数値の自動変換対策に全て文字列とする。取り込む列全てに配列で指定しなければいけないので、汎用性を考えOpen For Inputで一行目だけ抜き取り列数を取得している。
↓以下説明とか
VBA CSV ファイルの読み込み (QueryTables.Add 関数を使う)
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
.Name = "" 'クエリとしてのテーブル名
.CommandType = 0
.FieldNames = True
ファイルを指定して開く
Dim FileName
FileName = Application.GetOpenFilename("CSVファイル,*.csv")
Workbooks.Open FileName
実行するとファイル選択のダイアログボックスが表示される。
選択し【開く】を押すとファイルのフルパスを文字列として取得する。
↑この例ではCSVのみ表示される。
GetOpenFilenameメソッドの説明。
GetOpenFilename FileFilter, FilterIndex, Title, ButtonText, MultiSelect
| 引数 | 必須 or 任意 | 型 | 説明 |
| FileFilter | 任意 | 文字列 |
表示するファイルの種類を指定する。 |
| FilterIndex | 任意 | ||
| 引数 | 必須 or 任意 | 型 | 説明 |
| 引数 | 必須 or 任意 | 型 | 説明 |
| 引数 | 必須 or 任意 | 型 | 説明 |
XlGuessの自動判定とはExcelに表として認識された場合のみヘッダーとする。
CSVをExcelに取り込む
Dim tmp
Dim strBuf As String, strBuf1 As String
Dim i As Long
Dim LastLEN As Long
Dim shThis As Worksheet
Dim CSVpath As String
'シートとCSVのパスを指定
Set shThis = ThisWorkbook.Worksheets("")
CSVpath = ""
'取り込み先のシートをクリア
With shThis
.Cells.Clear
Open CSVpath For Input As #1
i = 1
Do Until EOF(1)
Line Input #1, strBuf
'セグメント内改行対策箇所
Do Until EOF(1)
If (Len(strBuf) - Len(Replace(strBuf, """", ""))) Mod 2 = 0 Then Exit Do
Line Input #1, strBuf1
strBuf = strBuf & strBuf1
Loop
'引用符削除
strBuf = Replace(strBuf, """,", ",")
strBuf = Replace(strBuf, ",""", ",")
strBuf = Replace(strBuf, """""", """")
If Left(strBuf, 1) = """" Then strBuf = Right(strBuf, Len(strBuf) - 1)
If Right(strBuf, 1) = """" Then strBuf = Left(strBuf, Len(strBuf) - 1)
'読み込んだ文字列を分割して配列に
tmp = Split(strBuf, ",")
'直前の配列と要素数が違えばメッセージ
If UBound(tmp) <> LastLEN And i > 1 Then msgbox "フィールド数が違う行があります。" & vbCrLf & "行：" & i
LastLEN = UBound(tmp)
'一行ずつ貼り付け
.Range(.Cells(i,1),.Cells(i,UBound(tmp)+1)) = tmp
i = i + 1
Loop
Close #1
End With
●問題点
文字の","が含まれていると、区切り文字の","を区別できないため分割される。
→カンマより左の引用符数をカウントして奇数なら文字の","と判別できる。が、数値の桁区切りの","には対応できない。
改行対策で改行を削除しているため実際のデータとは異なってくる。
配列を1要素ずつ指定すれば必要な列だけを抜き出すことも可能。
ただし要素を個別に張り付ける分、数が増えると処理時間が延びる。
先に表示形式を変えれば数値などの自動変換を防げる。
.Columns().NumberFormatLocal = "@" '文字列
※2018/4/24 修正
セグメント内改行対策コードの追加と引用符削除を手直し。
別のブックからシートを取り込む
Dim ws as worksheet
Dim wb as workbook
SN = "シート名"
BN = "ブック名"
Bpath = "ブックのPath"
'マクロ実行ブックに目的のシートがあれば消す
For Each ws In ThisWorkbook.Worksheets
If ws.Name = SN Then ws.Delete
Next ws
'目的のブックを開いているか判定
For Each WB In Workbooks
If WB.Name = BN Then fl = True
Next WB
'開いてたらコピーして取り込む、閉じてたら取り込んで閉じる
If fl Then
Workbooks(BN & ".xlsx").Sheets(SN).Copy Before:=ThisWorkbook.Sheets(1)
Else
Set WB = Workbooks.Open(Bpath & "\" & SN & ".xlsx")
WB.Sheets(SN).Move Before:=ThisWorkbook.Sheets(1)
End If
.
【RemoveDuplicates】重複削除する
・サンプル
Range("A1:B" & .Cells(1, 1).End(xlDown).Row).RemoveDuplicates Columns:=Array(1, 2),Header:=xlYes
このサンプルはA1からの連続最終行を求め、A1:B最終行の範囲を指定。
重複判定Columnsに1列目(A列),2列目(B列)を指定しヘッダー(範囲内の1行目)は残す設定。
式 Range.RemoveDuplicates(Columns, Header)
| 引数 | optional or required | 型 | 説明 |
| Columns | 必須 | バリアント型 | 重複判定する列のインデックスの配列を指定 |
| Header | 任意 | XlYesNoGuess | 1行目をヘッダーとするかどうか。XlGuessは自動判定 |
XlGuessの自動判定とはExcelに表として認識された場合のみヘッダーとする。
使わないほうが無難。
【AdvancedFilter】テーブルからデータ抽出
テーブルから条件を指定して抽出する
Worksheets("").Range("").AdvancedFilter _'テーブルを指定
Action:=xlFilterCopy, _
CriteriaRange:=Worksheets("").Range(""), _'抽出条件がある範囲を指定
CopyToRange:=Worksheets("").Range(""), _'抽出先を指定
Unique:=False
End Sub
| Action 必須 |
xlFilterCopy (値は2) |
リスト範囲とは他の場所に抽出データをコピーします |
| xlFilterInPlace (値は1) |
リスト範囲内にデータを抽出します | |
| CriteriaRange (省略可能) |
Variant型の値を使用する | 検索条件範囲を指定します。 省略すると、検索条件なしで抽出されます。 |
| CopyToRange (省略可能) |
Variant型の値を使用する | 引数 ActionがxlFilterCopyのときは、抽出された行のコピー先のセル範囲を指定します。 それ以外の場合、この引数は無視されます。 |
| Unique (省略可能) |
True | 検索条件に一致するレコードのうち、重複するレコードは無視されます。 |
| FALSE | 重複するレコードも含めて、検索条件に一致するレコードがすべて抽出されます。 |
・複数条件の指定方法
横に並べるとand、縦に並べるとor になる
| フィールド1 | フィールド1 | フィールド2 |
| abc | def | ghi |
| 123 | 456 | 789 |
この場合、or(and(フィールド1=abc,フィールド1=def,フィールド2=ghi),and(フィールド1=123,フィールド1=456,フィールド2=789))
が抽出される
