Excelマクロ 複数のシート検索・選択して新しいブックにコピー

質問

何方か、回答をお願いします。
下記のマクロは、任意のフォルダに有る全ての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.6

Wendy02 · ベストアンサー

こんばんは。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行迄データが有ります。)

回答No.5

Wendy02

こんばんは。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.4

Wendy02

こんばんは。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.3

Wendy02

こんばんは。

>作動確認はバッチリでした、
ビックリしました。ちょっと、信じられないです。^^;
そんなつもりではありませんでしたから。(←オイオイ)

>もし良ければ”この回答への補足”の方を宜しくお願いします。

>１）現在は、"C:\TestData\"でフォルダが決め打ちですが毎回フォルダが変更になりますのでフォルダを決めるダイアログボックスを出したい。

なるほどね。それで、ダイアログが必要だったのですね。それは、GetOpenFilename　では、ちょっとコードが違いますね。

そこで、こちらから、少し質問させてください。

>（２）シート全部にグラフを追加したいのでサブルーチンで下記のように入れたのですが、一枚だけグラフが書けて後は駄目でした何処にサブルーチンマクロを追加した方が良いでしょうか。？

それは、できれば、サブルーチンのほうが、修正作業に便利なのですが、ただし、同じシートの埋め込みグラフですか？それともグラフシートですか？

それと、貼り付けた数字等のデータは、全部、グラフ用に使えますか？

もう一つ大事なのは、データ自身は「A1」から始まっていますか？(タイトル行はあれば含めます)それとも、データの左上端の部分を探さなくてはなりませんか？

それらによって、場合によっては、一部のコードを変えなくてはならないと思います。

補足

Wendy02様回答ありがとう御座います。

グラフの件は、同じシートの埋め込みグラフです。（ｙ軸が対数の散布図）

＞それと、貼り付けた数字等のデータは、全部、グラフ用に使えますか？
はい、使えると思います。

「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.2

Wendy02

こんばんは。

私には、元のコードは読みきれませんでしたね。

最初に、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様回答ありがとう御座います。
済みません、変なコードで(^^ゞ
このマクロは、いろいろ人が少しずつ修正していった物で（私も修正しましたが）上級者
が見ると変なマクロに見えるのですね、私もまあ動くから深く考えなかったです。。。。
初めから全部書いて貰って良かったです、私も誰か全部書いてくれないかなーと思って
いましたので。
作動確認はバッチリでした、もし良ければ”この回答への補足”の方を宜しくお願いします。

補足

もし良ければ、Wendy02様下記の二カ所の修正を御教授して下さい。
（１）現在は、"C:\TestData\"でフォルダが決め打ちですが毎回フォルダが変更に
なりますのでフォルダを決めるダイアログボックスを出したい。

（２）シート全部にグラフを追加したいのでサブルーチンで下記のように入れたので
すが、一枚だけグラフが書けて後は駄目でした何処にサブルーチンマクロを追加した
方が良いでしょうか。？
NewWb.Worksheets(i).Name = ShName
　　　　　　　　　グラフ作成マクロ　　　　’追加しました。
i = i + 1

回答No.1

Takahiro_2002

こんばんは。

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に戻してあげてください。

お礼

Takahiro_2002様回答ありがとう御座います。
今度、修正したいと思います。
今回は、ありがとう御座いました。