何方か、回答をお願いします。
下記のマクロは、任意のフォルダに有る全てのxlsファイルのシート名が”Data”のみ
新しいブックにコピー(シート名は、元のファイル名に変更)をしていくマクロですが、
条件が下記のように変更になりました。
シート名は、DataとAppend*(*は数字で1~99)(Appendの数は毎回ばらばらでAppend
シートその物が無い場合も有ります。)を選択して新しいブックにコピー
(元のシート名の前に元のファイル名を足して新しいシート名は”ファイル名Append2”
こんな感じにしたいです。)したいのですがどの様なマクロを書けば良いのか教えて
下さい。
Sub test-xls版()
Dim myPName As String
Dim myKAKUCHOSI As String
Dim myPATHNAME As String
Dim myLName As String
Dim wb As Workbook
Dim wb_New As Workbook
Dim N As Byte
Dim ws As Worksheet
Dim myFN As String
myPName = Application.GetOpenFilename("測定データ(*.xls;*.csv),*.xls;*.csv")
If myPName = "False" Then Exit Sub
Application.ScreenUpdating = False
Set wb_New = Workbooks.Add
myKAKUCHOSI = Right(myPName, 4)
myPATHNAME = CurDir
myLName = Dir("")
N = Len(myLName)
myFN = Left(myLName, N - 4)
Do While myLName <> ""
Workbooks.OpenText Filename:=myPATHNAME & "\" & myLName, DataType:=xlDelimited, Tab:=True, Comma:=True, Space:=True
N = Len(myLName)
myFN = Left(myLName, N - 4)
Sheets("Data").Select 'csvの場合無し
Set wb = ActiveWorkbook
wb.ActiveSheet.Copy after:=wb_New.Sheets(wb_New.Worksheets.Count)
Worksheets("Data").Name = myFN 'csvの場合無し
wb.Close savechanges:=False
myLName = Dir()
Loop
Application.ScreenUpdating = True
Exit Sub
No.1
- 回答日時:
こんばんは。
Sheets("Data").Select 'csvの場合無し
Worksheets("Data").Name = myFN 'csvの場合無し
こいらへんを、
For i = 1 To Worksheets.Count
if worksheets(i).name like "Append[0-9]" or _
worksheets(i).name like "Append[0-9][0-9]" or _
worksheets(i).name = "Data" then
worksheets(i).Select 'csvの場合無し
end if
Next
な具合に変えてみるのが手っ取り早そうです。
何をやってるかというと、
BookのSheetの枚数を確認して
Sheetの名前がAppend*、Append**、Data(*は任意の数字一文字)に該当するときに上の例の場合Sheetを選択する。
と逝った動き方をします。
Sheetの枚数が多い場合は、Application.ScreenupdatingプロパティをFalseにしてあげると多少レスポンスが向上するかと存じます。
マクロが終了するときにはTrueに戻してあげてください。
No.2
- 回答日時:
こんばんは。
私には、元のコードは読みきれませんでしたね。
最初に、GetOpenFilename で、xls と csv を読んでいるのに、Dir() でループしているのだから、GetOpenFilenameは、意味がないのではないでしょうか?本来は、FileSearch を使うのが良いのかもしれませんが、FileSeach には、バグがありますので、敬遠しました。
また、
>myLName = Dir("")
この意味など、分からなかったです。まったく関係のないファイル名が取れます。
そんな状態なので、意味が確実に理解しているとは言えませんが、自分なりのコードを作ってみました。CSV ファイルは、そのファイル名の拡張子を除いたものを、シート名にしました。
'---------------------------------------------------------
Sub OpenAddData()
Dim MyCurPath As String
Dim FName As String
Dim NewWb As Workbook
Dim Sh As Variant
Dim i As Integer
Dim flg As Boolean
Dim ShName As String
'ユーザーのデータ・フォルダ
Const WORKPATH As String = _
"C:\TestData\"
MyCurPath = CurDir()
ChDir WORKPATH
FName = Dir("*.*")
Application.ScreenUpdating = False
Set NewWb = Workbooks.Add
i = 1
Do While FName <> ""
If FName Like "*.xls" Or FName Like "*.csv" Then
Select Case FName Like "*.xls"
Case True
With Workbooks.Open(FName)
For Each Sh In .Worksheets
If Sh.Name Like "Data" Or Sh.Name Like "Append#*" Then
If WorksheetFunction.Count(Sh.UsedRange) > 1 Then
If i > NewWb.Worksheets.Count Then NewWb.Worksheets.Add After:=NewWb.Worksheets(NewWb.Worksheets.Count)
Sh.UsedRange.Copy NewWb.Worksheets(i).Range("A1")
ShName = Mid(FName, 1, InStrRev(FName, ".") - 1) & Sh.Name
NewWb.Worksheets(i).Name = ShName
i = i + 1
End If
End If
Next Sh
.Close False
End With
Case Else
Workbooks.OpenText _
Filename:=FName, _
DataType:=xlDelimited, _
Tab:=True, _
Comma:=True, _
Space:=True
If i > NewWb.Worksheets.Count Then NewWb.Worksheets.Add After:=NewWb.Worksheets(NewWb.Worksheets.Count)
ActiveSheet.UsedRange.Copy NewWb.Worksheets(i).Range("A1")
ActiveWorkbook.Close False
ShName = Mid(FName, 1, InStrRev(FName, ".") - 1)
NewWb.Worksheets(i).Name = ShName
i = i + 1
End Select
End If
FName = Dir()
Loop
Set NewWb = Nothing
Application.ScreenUpdating = True
End Sub
この回答への補足
もし良ければ、Wendy02様下記の二カ所の修正を御教授して下さい。
(1)現在は、"C:\TestData\"でフォルダが決め打ちですが毎回フォルダが変更に
なりますのでフォルダを決めるダイアログボックスを出したい。
(2)シート全部にグラフを追加したいのでサブルーチンで下記のように入れたので
すが、一枚だけグラフが書けて後は駄目でした何処にサブルーチンマクロを追加した
方が良いでしょうか。?
NewWb.Worksheets(i).Name = ShName
グラフ作成マクロ ’追加しました。
i = i + 1
Wendy02様回答ありがとう御座います。
済みません、変なコードで(^^ゞ
このマクロは、いろいろ人が少しずつ修正していった物で(私も修正しましたが)上級者
が見ると変なマクロに見えるのですね、私もまあ動くから深く考えなかったです。。。。
初めから全部書いて貰って良かったです、私も誰か全部書いてくれないかなーと思って
いましたので。
作動確認はバッチリでした、もし良ければ”この回答への補足”の方を宜しくお願いします。
No.3
- 回答日時:
こんばんは。
>作動確認はバッチリでした、
ビックリしました。ちょっと、信じられないです。^^;
そんなつもりではありませんでしたから。(←オイオイ)
>もし良ければ”この回答への補足”の方を宜しくお願いします。
>1)現在は、"C:\TestData\"でフォルダが決め打ちですが毎回フォルダが変更になりますのでフォルダを決めるダイアログボックスを出したい。
なるほどね。それで、ダイアログが必要だったのですね。それは、GetOpenFilename では、ちょっとコードが違いますね。
そこで、こちらから、少し質問させてください。
>(2)シート全部にグラフを追加したいのでサブルーチンで下記のように入れたのですが、一枚だけグラフが書けて後は駄目でした何処にサブルーチンマクロを追加した方が良いでしょうか。?
それは、できれば、サブルーチンのほうが、修正作業に便利なのですが、ただし、同じシートの埋め込みグラフですか?それともグラフシートですか?
それと、貼り付けた数字等のデータは、全部、グラフ用に使えますか?
もう一つ大事なのは、データ自身は「A1」から始まっていますか?(タイトル行はあれば含めます)それとも、データの左上端の部分を探さなくてはなりませんか?
それらによって、場合によっては、一部のコードを変えなくてはならないと思います。
この回答への補足
Wendy02様回答ありがとう御座います。
グラフの件は、同じシートの埋め込みグラフです。(y軸が対数の散布図)
>それと、貼り付けた数字等のデータは、全部、グラフ用に使えますか?
はい、使えると思います。
「A1」の方は。計測器が出すヘッダだらしき物が入ります。
サブルーチンマクロの方は、前のマクロでは下記に入れたと思います。
Worksheets("Data").Name = myFN 'csvの場合無し
グラフ作成マクロ ’ここに入れたと思います。
wb.Close savechanges:=False
*******************************************************
Sub グラフ作成マクロ()
Dim r1 As Range
Dim r2 As Range
Dim MyMultipleselection As Range
Set r1 = Range("B2", Range("B2").End(xlDown)) 'X軸となるデータ範囲
Set r2 = Range("C2", Range("C2").End(xlDown)) 'Y軸となるデータ範囲
Set MyMultipleselection = Union(r1, r2)
’グラフタイトルは、シート名と同じ XY軸のレンジはオートです。
以下省略
No.4
- 回答日時:
こんばんは。
Wendy02です。遅くなってすみません。こういうレベルになると、夜になって集中しないと作れません。
今まで、使っていたサブルーチンがありましたら、そちらに替えても結構です。以下では、引数が、シートオブジェクトにしてあります。サブルーチンの位置を気をつけてください。片方は、データのブックが閉じてからグラフを作るようになっています。
>>それと、貼り付けた数字等のデータは、全部、グラフ用に使えますか?
>はい、使えると思います。
すみません。一応、自分の場合、交じり合ったデータでしたので、使えない場合も想定させていただきました。グラフが出来上がっていなければ、使えなかったことになります。グラフ位置は、数値データよりも、少し下に出来上がるように作られています。
'-------------------------------------------------------------
Sub OpenAddData_R()
Dim MyCurPath As String
Dim FName As String
Dim NewWb As Workbook
Dim Sh As Variant
Dim i As Integer
Dim objFolder As Object
Dim WorkPath As Variant
Dim ShName As String
'初期フォルダ
Const MYDRIVE As String = "C:\TestData\"
Set objFolder = CreateObject("Shell.Application"). _
BrowseForFolder(0, "フォルダを選んでください。", 0, MYDRIVE)
If objFolder Is Nothing Then Exit Sub
WorkPath = objFolder.self.Path
MyCurPath = CurDir()
ChDir WorkPath
FName = Dir("*.*")
Application.ScreenUpdating = False
Set NewWb = Workbooks.Add
i = 1
Do While FName <> ""
If FName Like "*.xls" Or FName Like "*.csv" Then
Select Case FName Like "*.xls"
Case True
With Workbooks.Open(FName)
For Each Sh In .Worksheets
If Sh.Name Like "Data" Or Sh.Name Like "Append*" Then
If WorksheetFunction.Count(Sh.UsedRange) > 1 Then
If i > NewWb.Worksheets.Count Then NewWb.Worksheets.Add After:=NewWb.Worksheets(NewWb.Worksheets.Count)
Sh.UsedRange.Copy NewWb.Worksheets(i).Range("A1")
ShName = Mid(FName, 1, InStrRev(FName, ".") - 1) & Sh.Name
NewWb.Worksheets(i).Name = ShName
'サブルーチン(グラフ作成)
MakingChartObj NewWb.Worksheets(i)
i = i + 1
End If
End If
Next Sh
.Close False
End With
Case Else
Workbooks.OpenText _
Filename:=FName, _
DataType:=xlDelimited, _
Tab:=True, _
Comma:=True, _
Space:=True
If i > NewWb.Worksheets.Count Then NewWb.Worksheets.Add After:=NewWb.Worksheets(NewWb.Worksheets.Count)
ActiveSheet.UsedRange.Copy NewWb.Worksheets(i).Range("A1")
ActiveWorkbook.Close False
'サブルーチン(グラフ作成)
MakingChartObj NewWb.Worksheets(i)
ShName = Mid(FName, 1, InStrRev(FName, ".") - 1)
NewWb.Worksheets(i).Name = ShName
i = i + 1
End Select
End If
FName = Dir()
Loop
Set NewWb = Nothing
Application.ScreenUpdating = True
End Sub
Sub MakingChartObj(NewSheet As Worksheet)
'グラフ作成用サブルーチン
Dim ChrtRng As Range
With NewSheet.Range("A1:B1").CurrentRegion
On Error Resume Next
Set ChrtRng = .Offset(1).Columns("B:C").Resize(.Rows.Count - 1, 2)
If ChrtRng.Count < 2 Or WorksheetFunction.Count(ChrtRng) < 2 Then Set ChrtRng = Nothing: Exit Sub
On Error GoTo 0
If Err.Number > 0 Then Err.Clear: Exit Sub
Application.Goto ChrtRng
' ChrtRng.Select '必要ないが、予備に置いておく。
End With
Charts.Add
With ActiveChart
.ChartType = xlXYScatter
.SetSourceData Source:=ChrtRng, _
PlotBy:=xlColumns
.Location Where:=xlLocationAsObject, Name:=NewSheet.Name
End With
With ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = NewSheet.Name
.Axes(xlCategory, xlPrimary).HasTitle = False
.Axes(xlValue, xlPrimary).HasTitle = False
.Parent.Top = ChrtRng.Cells(ChrtRng.Cells.Count).Top + 20 'グラフの位置
End With
Set ChrtRng =Nothing
End Sub
Wendy02様回答ありがとう御座います。
今回も、長文の回答でご苦労様でした。
全てが、xlsファイルの場合完璧でした、全てがcsvファイルの場合は
グラフタイトルがSheet*になりましたが、これ位は私の方で修正したいと思います。
今回もありがとうございました。
No.5
- 回答日時:
こんばんは。
Wendy02です。>グラフタイトルがSheet*になりましたが、これ位は私の方で修正したいと思います。
すみません。本当ですね。昨日は、チェックしたつもりでも、コードだけでみても間違いが分かりました。
Case Else
~
'サブルーチン(グラフ作成)
MakingChartObj NewWb.Worksheets(i)
ShName = Mid(FName, 1, InStrRev(FName, ".") - 1)
NewWb.Worksheets(i).Name = ShName
↓
ShName = Mid(FName, 1, InStrRev(FName, ".") - 1)
NewWb.Worksheets(i).Name = ShName
'サブルーチン(グラフ作成)
MakingChartObj NewWb.Worksheets(i)
(シート名を付ける前に、グラフを作ろうとしているのだから、間違っているのは当然でした)
ただし、今は、コードをみただけですから、動作試験していません。
この回答への補足
Wendy02様回答ありがとう御座います。
グラフタイトルの件はバッチリでした。
何回も済みませんが、時間があるときで結構ですので下記を教えて下さい。
現在はグラフのデータ領域は、多分A1を起点に連続領域だと思いますが、
今度、列と列の間に空列が入る可能性が有るので。
Range("B2:B100") 'X軸となるデータ範囲
Range("E2:E100") 'Y軸となるデータ範囲
この様に、決め打ちで領域をセットする場合どの様に書けば良いのでしょうか。?
宜しくお願いします。
No.6ベストアンサー
- 回答日時:
こんばんは。
Wendy02です。>多分A1を起点に連続領域だと思いますが、
その辺りは、ある程度の余裕は考えていましたが、離れている場所には適用できません。
本来は、グラフは以下のようにするのではなく、VBAらしさを出すには、最初から、ChartObjects で作るのが正しいようなのですが、大きさが決まらないのと、今度は、散布図の場合は、片方が入らないので、以下のような変則的なマクロになっています。
他に変更した部分は、グラフの位置ですが、100行となると、下に置くわけにはいかないようなので、横に置くことにしました。また、凡例は抜くようにしました。
'-------------------------------------------------------------
'サブルーチンのみ変更
Sub MakingChartObj(NewSheet As Worksheet)
Dim Data1 As Range
Dim Data2 As Range
Set Data1 = NewSheet.Range("B2:B100") 'X軸となるデータ範囲
Set Data2 = NewSheet.Range("E2:E100") 'Y軸となるデータ範囲
'データエラーチェック
If Data1.Count < 2 Or WorksheetFunction.Count(Data1) < 2 Then
Set Data1 = Nothing
Exit Sub
If Data2.Count < 2 Or WorksheetFunction.Count(Data2) < 2 Then
Set Data1 = Nothing
Set Data2 = Nothing
Exit Sub
End If
End If
Application.Goto Data1
Charts.Add
With ActiveChart
.ChartType = xlXYScatter
.SetSourceData Source:=Data2, _
PlotBy:=xlColumns
.Location Where:=xlLocationAsObject, Name:=NewSheet.Name
End With
With ActiveChart '仕切りなおし
.SeriesCollection(1).XValues = "=" & NewSheet.Name & "!" & Data1.Address(1, 1, xlR1C1)
.HasTitle = True
.ChartTitle.Characters.Text = NewSheet.Name
.HasLegend = False '凡例なし
.Axes(xlCategory, xlPrimary).HasTitle = False
.Axes(xlValue, xlPrimary).HasTitle = False
'グラフの位置
.Parent.Top = Data1.Cells(1).Top + 10 '上の位置
.Parent.Left = Data2.Cells(1, 2).Left + 10 '横付けする
End With
Set Data1 = Nothing: Set Data2 = Nothing
End Sub
この回答への補足
Wendy02様回答ありがとう御座います。
グラフの件ですがY軸は正常、X軸が値でなく空白が入ってしまう現象が
起きましたので何回も済みませんが、時間があるときで結構ですので下記
下記の直し方を教えて下さい。
下記の1行をコメントアウトしたらグラフは完成します。(X軸が値でなく空白)
(エラー表示:SeriesクラスのXValuesプロパティを設定出来ません。)
'.SeriesCollection(1).XValues = "=" & NewSheet.Name & "!" & Data1.Address(1, 1, xlR1C1)
(参考:データエラーチェックの方でNothingの方には行っていません。)
今回使用したデータ
stato_____X-ziku___________Y-ziku
0_________0.0000E+0________8.9400E-12
__________5.0000E+0________5.7600E-12
_________10.0000E+0________3.5400E-12
_________15.0000E+0________1.6600E-12
(statoがA1でY-zikuがC1で52行迄データが有ります。)
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
関連するカテゴリからQ&Aを探す
おすすめ情報
- ・漫画をレンタルでお得に読める!
- ・人生のプチ美学を教えてください!!
- ・10秒目をつむったら…
- ・あなたの習慣について教えてください!!
- ・牛、豚、鶏、どれか一つ食べられなくなるとしたら?
- ・【大喜利】【投稿~9/18】 おとぎ話『桃太郎』の知られざるエピソード
- ・街中で見かけて「グッときた人」の思い出
- ・「一気に最後まで読んだ」本、教えて下さい!
- ・幼稚園時代「何組」でしたか?
- ・激凹みから立ち直る方法
- ・1つだけ過去を変えられるとしたら?
- ・【あるあるbot連動企画】あるあるbotに投稿したけど採用されなかったあるある募集
- ・【あるあるbot連動企画】フォロワー20万人のアカウントであなたのあるあるを披露してみませんか?
- ・映画のエンドロール観る派?観ない派?
- ・海外旅行から帰ってきたら、まず何を食べる?
- ・誕生日にもらった意外なもの
- ・天使と悪魔選手権
- ・ちょっと先の未来クイズ第2問
- ・【大喜利】【投稿~9/7】 ロボットの住む世界で流行ってる罰ゲームとは?
- ・推しミネラルウォーターはありますか?
- ・都道府県穴埋めゲーム
- ・この人頭いいなと思ったエピソード
- ・準・究極の選択
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
エクセルのグラフ作成で軸を等...
-
エクセルの縦軸(Y軸)が不均等...
-
エクセル グラフの”データーテ...
-
Excelでx軸とy軸を設定して図を...
-
EXCELでグラフを作るとき、縦軸...
-
エクセルで折れ線と散布図を同...
-
エクセルの対数グラフのエラー
-
Excel:別シートにグラフを貼り...
-
エクセルで、極座表のグラフ描...
-
エラーバーの終端の線を長くする
-
Excelグラフの項目軸について
-
エクセル 0や空白のセルをグラ...
-
ExcelでIF関数によるグラフの表...
-
エクセル グラフはあるけれど...
-
ワードの差し込みにて、値をグ...
-
エクセルのグラフの1点の色を変...
-
歯抜けのグラフを何とかしたい...
-
Excelグラフの有効数字の統一が...
-
Excel 複数のシートにあるグラ...
-
Excelマクロ・グラフエリア・プ...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
エクセルのグラフ作成で軸を等...
-
EXCELでグラフを作るとき、縦軸...
-
Excel:別シートにグラフを貼り...
-
エクセルの縦軸(Y軸)が不均等...
-
Excelでx軸とy軸を設定して図を...
-
エクセルで折れ線と散布図を同...
-
エクセルで折れ線グラフ(散布...
-
エクセル 0や空白のセルをグラ...
-
エクセルで、極座表のグラフ描...
-
エクセル グラフはあるけれど...
-
エクセル グラフの”データーテ...
-
エクセルの円を5等分する方法
-
散布図を縦に2個並べて出力したい
-
エクセルの対数グラフのエラー
-
<EXCELグラフ>データ取得範囲...
-
ExcelのグラフをPowerPointに貼...
-
エクセルグラフの項目名を折り...
-
EXCELのグラフ作成時に元データ...
-
ワードの差し込みにて、値をグ...
-
エクセルのグラフの1点の色を変...
おすすめ情報