おまけ
テキストデータのタブ区切り、空白区切りを選択できます。
x軸のデータを編集する必要がある場合など、x軸を固定して散布図を作成することができます。
今回紹介するコードは、テキストの最大列数を保持するため散布図作成時に入力する必要はありません。
テキストの読み込みが終わった状態でエクセルを閉じてしまうと最大列数が保持されません。テキストの読み込みと散布図作成を一気に行うか、後編で紹介したコードで手動で列数を入力するようにしてください。
Dim column_quant As Long
Sub テキストファイルを順番に読み込みしてエクセルへ転記タブ区切り()
Dim openFilePath As Variant
Dim pt As Variant
Dim MacroFile As Workbook
Dim Cnt As Long
Dim i As Long
Dim data_quant As Long
'開いているシートの編集をする
Set MacroFile = ActiveWorkbook
'取り込みデータの最大列数の入力画面を出力
column_quant = Application.InputBox(prompt:="取り込むデータの列数を入力して下さい", _
title:="数値入力", _
Type:=1)
If column_quant = False Then
MsgBox "キャンセルします"
Exit Sub
End If
'ファイルを開くダイアログ（複数ファイル選択OK）
openFilePath = Application.GetOpenFilename _
("テキストファイル(allも可)(*.txt;*.all),*.txt;*.all", , "テキストファイルを選択", MultiSelect:=True)
'テキストファイルを開く
If IsArray(openFilePath) Then
Cnt = 1
'選択したファイルを順番に開く
For Each pt In openFilePath
'マクロ中の画面の切り替えを非表示にする（マクロが軽くなります）
Application.ScreenUpdating = False
'テキストファイルの貼り付け設定
'consecutive-連続する区切り文字
'Datatype-固定長のフィールドデータの設定
'その他のオンオフ、trueがオンでfalseがオフです
Workbooks.OpenText Filename:=pt, _
ConsecutiveDelimiter:=True, _
DataType:=xlDelimited, _
Tab:=True, _
Semicolon:=False, _
Comma:=False, _
Space:=False, _
Other:=False, _
otherchar:=""
For i = 1 To column_quant
Columns(i).Copy MacroFile.ActiveSheet.Cells(1, Cnt + i + 6)
Next
Cnt = Cnt + column_quant + 2
'テキストファイル閉じる
ActiveWorkbook.Close False
Next pt
End If
End Sub
Sub テキストファイルを順番に読み込みしてエクセルへ転記空白区切り()
Dim openFilePath As Variant
Dim pt As Variant
Dim MacroFile As Workbook
Dim Cnt As Long
Dim i As Long
Dim data_quant As Long
'開いているシートの編集をする
Set MacroFile = ActiveWorkbook
'取り込みデータの最大列数の入力画面を出力
column_quant = Application.InputBox(prompt:="取り込むデータの列数を入力して下さい", _
title:="数値入力", _
Type:=1)
If column_quant = False Then
MsgBox "キャンセルします"
Exit Sub
End If
'ファイルを開くダイアログ（複数ファイル選択OK）
openFilePath = Application.GetOpenFilename _
("テキストファイル(allも可)(*.txt;*.all),*.txt;*.all", , "テキストファイルを選択", MultiSelect:=True)
'テキストファイルを開く
If IsArray(openFilePath) Then
Cnt = 1
'選択したファイルを順番に開く
For Each pt In openFilePath
'マクロ中の画面の切り替えを非表示にする（マクロが軽くなります）
Application.ScreenUpdating = False
'テキストファイルの貼り付け設定
'consecutive-連続する区切り文字
'Datatype-固定長のフィールドデータの設定
'その他のオンオフ、trueがオンでfalseがオフです
Workbooks.OpenText Filename:=pt, _
ConsecutiveDelimiter:=True, _
DataType:=xlDelimited, _
Tab:=False, _
Semicolon:=False, _
Comma:=False, _
Space:=True, _
Other:=False, _
otherchar:=""
For i = 1 To column_quant
Columns(i).Copy MacroFile.ActiveSheet.Cells(1, Cnt + i + 6)
Next
Cnt = Cnt + column_quant + 2
'テキストファイル閉じる
ActiveWorkbook.Close False
Next pt
End If
End Sub
Sub x軸固定散布図作成_基本こっち()
If column_quant = False Then
MsgBox "x軸固定散布図作成_読み込んだテキストデータの列数入力必要で実行してください。"
Exit Sub
End If
Dim data_quant As Long
Dim x_cell As Range
Dim y_cell As Range
Dim series_cell As Range
Dim y_axis_r As Long
Dim y_axis_c As Long
Dim title As String
Dim row_x As Long
Dim row_y As Long
'以下データ入力
data_quant = Application.InputBox(prompt:="グラフ作成するデータ数を入力してください", _
title:="数値入力", _
Type:=1)
If data_quant = False Then
MsgBox "キャンセルします"
Exit Sub
End If
On Error Resume Next
Set x_cell = Application.InputBox(prompt:="一個目のx軸のデータを選択してください", _
title:="セル選択", _
Type:=8)
'キャンセルされた場合はSetがエラーとなる
If Err.Number = 0 Then
Else
MsgBox "キャンセルされました。"
Exit Sub
End If
Set y_cell = Application.InputBox(prompt:="一個目のy軸のデータを選択してください", _
title:="セル選択", _
Type:=8)
'キャンセルされた場合はSetがエラーとなる
If Err.Number = 0 Then
Else
MsgBox "キャンセルされました。"
Exit Sub
End If
Set y_cell = Application.InputBox(prompt:="一個目のy軸のデータを選択してください", _
title:="セル選択", _
Type:=8)
'キャンセルされた場合はSetがエラーとなる
If Err.Number = 0 Then
Else
MsgBox "キャンセルされました。"
Exit Sub
End If
Set series_cell = Application.InputBox(prompt:="一個目の系列名のデータを選択してください", _
title:="セル選択", _
Type:=8)
'キャンセルされた場合はSetがエラーとなる
If Err.Number = 0 Then
Else
MsgBox "キャンセルされました。"
Exit Sub
End If
On Error GoTo 0
title = Application.InputBox(prompt:="グラフタイトルを入力してください", _
title:="タイトル", _
Type:=2)
If title = False Then
MsgBox "キャンセルします"
Exit Sub
End If
'データ入力終わり
Application.ScreenUpdating = False '画面切り替えのオフ（動作を軽くします）
Dim ch As Chart
Set ch = ActiveSheet.ChartObjects.Add(10, 0, 400, 300).Chart 'グラフの位置設定
ch.ChartType = xlXYScatterLinesNoMarkers 'グラフの種類（マーカーなし折れ線）
With ch
.HasTitle = True
.ChartTitle.Text = title 'タイトル名を入力してください
'.HasLegend = True
'.Legend.Position = xlLegendPositionBottom '凡例表示をオンにします
End With
x_axis_r = x_cell.Row
x_axis_c = x_cell.column
y_axis_r = y_cell.Row
y_axis_c = y_cell.column
series_r = series_cell.Row
series_c = series_cell.column
For i = 1 To data_quant
row_x = Cells(x_axis_r, x_axis_c).End(xlDown).Row
row_y = Cells(y_axis_r, y_axis_c + (i - 1) * (column_quant + 2)).End(xlDown).Row
With ch.SeriesCollection.NewSeries
.XValues = Range(Cells(x_axis_r, x_axis_c), Cells(row_x, x_axis_c))
.Values = Range(Cells(y_axis_r, y_axis_c + (i - 1) * (column_quant + 2)), Cells(row_y, y_axis_c + (i - 1) * (column_quant + 2)))
.Name = Cells(series_r + i - 1, series_c)
End With
Next
End Sub
Sub 散布図作成_基本こっち()
If column_quant = False Then
MsgBox "散布図作成_読み込んだテキストデータの列数入力必要で実行してください。"
Exit Sub
End If
Dim data_quant As Variant
Dim x_cell As Range
Dim y_cell As Range
Dim series_cell As Range
Dim x_axis_r As Long
Dim x_axis_c As Long
Dim y_axis_r As Long
Dim y_axis_c As Long
Dim title As Variant
Dim row_x As Long
Dim row_y As Long
'以下データ入力
data_quant = Application.InputBox(prompt:="グラフ作成するデータ数を入力してください", _
title:="数値入力", _
Type:=1)
If data_quant = False Then
MsgBox "キャンセルします"
Exit Sub
End If
On Error Resume Next
Set x_cell = Application.InputBox(prompt:="一個目のx軸のデータを選択してください", _
title:="セル選択", _
Type:=8)
'キャンセルされた場合はSetがエラーとなる
If Err.Number = 0 Then
Else
MsgBox "キャンセルされました。"
Exit Sub
End If
Set y_cell = Application.InputBox(prompt:="一個目のy軸のデータを選択してください", _
title:="セル選択", _
Type:=8)
'キャンセルされた場合はSetがエラーとなる
If Err.Number = 0 Then
Else
MsgBox "キャンセルされました。"
Exit Sub
End If
Set series_cell = Application.InputBox(prompt:="一個目の系列名のデータを選択してください", _
title:="セル選択", _
Type:=8)
'キャンセルされた場合はSetがエラーとなる
If Err.Number = 0 Then
Else
MsgBox "キャンセルされました。"
Exit Sub
End If
On Error GoTo 0
title = Application.InputBox(prompt:="グラフタイトルを入力してください", _
title:="タイトル", _
Type:=2)
If title = False Then
MsgBox "キャンセルします"
Exit Sub
End If
'データ入力終わり
Application.ScreenUpdating = False '画面切り替えのオフ（動作を軽くします）
Dim ch As Chart
Set ch = ActiveSheet.ChartObjects.Add(10, 0, 400, 300).Chart 'グラフの位置設定
ch.ChartType = xlXYScatterLinesNoMarkers 'グラフの種類（マーカーなし折れ線）
With ch
.HasTitle = True
.ChartTitle.Text = title 'タイトル名を入力してください
'.HasLegend = True
'.Legend.Position = xlLegendPositionBottom '凡例表示をオンにします
End With
x_axis_r = x_cell.Row
x_axis_c = x_cell.column
y_axis_r = y_cell.Row
y_axis_c = y_cell.column
series_r = series_cell.Row
series_c = series_cell.column
For i = 1 To data_quant
row_x = Cells(x_axis_r, x_axis_c + (i - 1) * (column_quant + 2)).End(xlDown).Row
row_y = Cells(y_axis_r, y_axis_c + (i - 1) * (column_quant + 2)).End(xlDown).Row
With ch.SeriesCollection.NewSeries
.XValues = Range(Cells(x_axis_r, x_axis_c + (i - 1) * (column_quant + 2)), Cells(row_x, x_axis_c + (i - 1) * (column_quant + 2)))
.Values = Range(Cells(y_axis_r, y_axis_c + (i - 1) * (column_quant + 2)), Cells(row_y, y_axis_c + (i - 1) * (column_quant + 2)))
.Name = Cells(series_r + i - 1, series_c)
'.Line.ForeColor = i
End With
'With ActiveSheet.ChartObjects(1).Chart.SeriesCollection(i)
' .MarkerStyle = xlNone 'マーカーを非表示
'End With
Next
End Sub
