エクセルの学校：全文検索：Hyper Estraier： IF

Results of 1 - 1 of about 37672 for IF (0.008 sec.)

[[20111027111622]]: #score: 1591; @digest: 2dc17d810327eee2916215d534179d39; @id: 56434; @mdate: 2012-06-11T01:26:48Z; @size: 134184; @type: text/plain; #keywords: 社差 (279300), copywork (245997), pastpath (222668), copypath (164287), openpath (148650), mymonth (98329), 額" (87125), myfol (86441), 差額 (79083), afterupdate (74230), myarea (71137), listbox1 (37143), mycol (31081), myfile (27785), textbox3 (27117), ファ (24853), height (21880), textbox2 (21129), mypath (19602), ァイ (19243), イル (16249), caption (15711), ル名 (15408), private (14990), ォル (14535), width (14494), フォ (14069), list (12642), textbox1 (12386), ルダ (12162), string (11349), with (11017); 『1.VBAでファイル名の一部を一括変換』（ミニー）
はじめましてこのたびVBAで下記のような作業をしようと思っています。先月のフォルダとその中のエクセルをコピーして、今月のフォルダを作成しようと思っています。 ◆作成したもの【ユーザーフォーム】作成したい月:（）→当月を入力するテキストを作りました。フォルダとファイルコピーをするコマンド実行ボタンがあります。 ◆やりたいこと @"9月"というフォルダから"10月"フォルダを作成 A作成した10月フォルダの中にあるエクセルファイルの名前が "9月"という部分を10 月に変更。ファイル名はすべて"9月xxxxxxxxx.xls"という名前です。 Bコピーと名前の変更ができたらそのフォルダを表示ただ、フォルダを作成して、ファイルをコピーまではこの掲示板にも掲載されていたので、なんとかなりそうな気がするのですが、まとめてファイルの名前を変えるというところがわかりません。ご教授頂きたくお願いいたします。 ---- わからないのがファイル名の変更部分だけでしたら Dir関数でループさせて、Nameステートメントでリネームしてあげれば出来そうですね。サンプルを載せますので、これで引数を渡すようにしたりユーザーフォームから呼び出せる形にすれば出来るはずです。 Sub test() Dim myPath As String Dim BeforeText As String Dim AfterText As String myPath = "D:¥test¥" BeforeText = "9月" AfterText = "10月" myFile = Dir(myPath & BeforeText & "*.xls") Do Until myFile = "" Name myPath & myFile As myPath & Replace(myFile, BeforeText, AfterText) myFile = Dir() Loop End Sub （momo） ---- momoさまいとも簡単にありがとうございます。まだ他の部分ができてないので、試してないのですが後ほどやってみます。ですが、初心者で全部できる自信がありません。。できれば、最初から教えていただけると助かるのですが・・・書き忘れてしまいましたが、Excel2003ですよろしくおねがいいたします（vv） ---- 私が最初から書いてしまうのは簡単ですが、後々のメンテナンスに困りませんか? せっかく >この掲示板にも掲載されていたので、なんとかなりそうな気がするのですがという所まで調べておられるようですし、何とかなる部分まで頑張ってみませんか? わからない部分のサポートはしますから、ご自身で少しでも頑張ってみましょう。その方が後が楽ですし、上達も早いですよ。（momo） ---- はい、がんばってやってみます。ひとつ教えていただきたいのですが、ユーザーフォームのテキストから月が変わっても対応できるように、下記コードも変えたいのですが、どのようにすればいいでしょうか? ユーザーフォームのテキストの方法もそもそもいい方法なのかもわかりません。。 BeforeText = "9月" AfterText = "10月" よろしくおねがいします。 ---- >ユーザーフォームのテキストから月が変わっても対応できるように上のコードの中身をフォームのコードにして、 BeforeText = me.TextBox1.value AfterText = me.TextBox2.value のようにしても良いですが、単品のプロシージャとして汎用的に扱うのであれば Sub FileReName(BeforeText As String, AfterText As String) Dim myPath As String myPath = "D:¥test¥" myFile = Dir(myPath & BeforeText & "*.xls") Do Until myFile = "" Name myPath & myFile As myPath & Replace(myFile, BeforeText, AfterText) myFile = Dir() Loop End Sub のように書き換えます。 >Sub FileReName(BeforeText As String, AfterText As String) のようにプロシージャ名の()の中に変数を宣言するとそのプロシージャをコールする時に引数として値（または参照）を渡す事ができます。フォームのコードから、たとえばCommandButton1を押したときなら Private Sub CommandButton1_Click() FileReName Me.TextBox1.Value, Me.TextBox2.Value End Sub のようにすれば、TextBox1を"9月" TextBox2を"10月"とすれば同じように動きます。わかりやすく実験するなら Sub test2() test3 "テストです" End Sub Sub test3(a As String) MsgBox a End Sub こんなのでtest2を実行してみるとか（momo） ---- ありがとうございます(^^ 作成月（10月）しかテキスト作ってない場合は、 "TextBox2 - 1" というカンジで、9月を認識させることもできるのでしょうか? ---- え〜と、そのままでは当然エラーですが単純に-1だと1月の時に12月にならないので、こんなのを試してみてください日付型で前月を出しています。 Sub test4() Dim a As String Dim IntMonth As Integer Dim StrMonth As String a = "10月" IntMonth = Month(DateSerial(Year(Date), Val(StrConv(a, vbNarrow)), 0)) MsgBox IntMonth StrMonth = StrConv(IntMonth, vbWide) & "月" MsgBox StrMonth End Sub （momo） ---- はっΣ(ﾟДﾟ;) そうですよね。月や年が変わった場合のこと考えてませんでした。。今思ったのですが、コピー先、コピー元のフォルダの場所もユーザーフォームで指定するようにした方がいいでしょうか? ---- >コピー先、コピー元のフォルダの場所もユーザーフォームで指定するようにした方がいいでしょうか? 場所が変わったり、不確定な場所だったりするのでしたらその方が良いですね。（momo） ---- ちなみにフォルダ名はどのようになっていますか? D:¥・・・・¥9月のような感じで、その中に9月から始まるファイルがありますか? 9月から始まらないファイルやxls以外のファイルはありますか? 年が変わった場合は? と、色々考えないといけませんね。（momo） ---- ちょっと所用があって今日はもう見られないかもしれないので・・・参考に書いたコードで遊びながら試してみてください。わからない所はまた後日対応させて頂きます。事前準備として、新規のブックを開きます。ユーザーフォームを挿入して Labelを4個 TextBoxを4個 CommandButtonを3個配置してください。場所や大きさ、文字などはコード内で成形するので気にしなくて結構です。で、フォームのコード欄に以下を貼り付け Option Explicit Private Sub UserForm_Initialize() With Me .Height = 160 .Width = 290 With .Label1 .Caption = "コピー元フォルダ" .Top = 6 .Left = 12 .Height = 12 .Width = 60 End With With .Label2 .Caption = "コピー先フォルダ" .Top = 42 .Left = 12 .Height = 12 .Width = 60 End With With .Label3 .Caption = "置換ファイル名" .Top = 84 .Left = 12 .Height = 12 .Width = 70 End With With .Label4 .Caption = "置換後ファイル名" .Top = 84 .Left = 130 .Height = 12 .Width = 70 End With With .TextBox1 .Top = 18 .Left = 12 .Height = 18 .Width = 200 End With With .TextBox2 .Top = 54 .Left = 12 .Height = 18 .Width = 200 End With With .TextBox3 .Top = 96 .Left = 12 .Height = 18 .Width = 80 End With With .TextBox4 .Top = 96 .Left = 130 .Height = 18 .Width = 80 End With With .CommandButton1 .Caption = "参照" .Top = 18 .Left = 220 .Height = 18 .Width = 50 End With With .CommandButton2 .Caption = "参照" .Top = 54 .Left = 220 .Height = 18 .Width = 50 End With With .CommandButton3 .Caption = "コピー開始" .Top = 96 .Left = 220 .Height = 18 .Width = 50 End With End With End Sub Private Sub CommandButton1_Click() Dim myFol As String Dim myPath As String Dim myMonth As String With Application.FileDialog(msoFileDialogFolderPicker) If .Show = True Then myFol = .SelectedItems(1) If myFol Like "*月" Then Me.TextBox1.Value = myFol myPath = StrReverse(Split(StrReverse(myFol), "¥")(0)) Me.TextBox3.Value = myPath myMonth = Val(StrConv(StrReverse(Split(StrReverse(myFol), "¥")(0)), vbNarrow)) myMonth = StrConv(Month(DateSerial(Year(Date), myMonth + 1, 1)), vbWide) & "月" Me.TextBox4.Value = myMonth Me.TextBox2.Value = Replace(myFol, myPath, myMonth) End If End If End With End Sub Private Sub CommandButton2_Click() With Application.FileDialog(msoFileDialogFolderPicker) If .Show = True Then Me.TextBox2.Value = .SelectedItems(1) End If End With End Sub Private Sub CommandButton3_Click() Dim CopyPath As String Dim PastePath As String Dim myFile As String CopyPath = Me.TextBox1.Value PastePath = Me.TextBox2.Value If CopyPath = "" Or PastePath = "" Then MsgBox "フォルダが指定されていません" Else If Dir(PastePath, vbDirectory) = "" Then If MsgBox(PastePath & "フォルダがありません。" & vbCr & _ "フォルダを作成しますか?", vbYesNo) = vbYes Then MkDir PastePath Else MsgBox "キャンセルされました" Exit Sub End If End If myFile = Dir(CopyPath & "¥*.*") Do Until myFile = "" If myFile Like "*" & Me.TextBox3.Value & "*" Then FileCopy CopyPath & "¥" & myFile, PastePath & "¥" & Replace(myFile, Me.TextBox3.Value, Me.TextBox4.Value) Else FileCopy CopyPath & "¥" & myFile, PastePath & "¥" & myFile End If myFile = Dir() Loop End If End Sub これで、実行してみてください。年の変わり目は対応していません。あくまでサンプルです。（momo） ---- えーーーっ!! ユーザーフォーム自分で手作りで作るのが当たり前だと思っていました! こうやって作ることが出来るんですね!! フォルダのダイアログのところで質問なのですが途中までアドレスが決まっているものは、デフォルトで表示させて参照ボタンを押したとき、そこからダイアログを開くこともできますか? またお時間あるときにご教授お願いします。 ---- >ユーザーフォーム自分で手作りで作るのが当たり前だと思っていましたもちろん、普通は手作りです。デザインをこのような場所では伝えにくいのでコードで成形しただけです。 >途中までアドレスが決まっているものは、デフォルトで表示させて参照ボタンを押したとき、 >そこからダイアログを開くこともできますか? これは >With Application.FileDialog(msoFileDialogFolderPicker) という行が Private Sub CommandButton1_Click() Private Sub CommandButton2_Click() の2つのプロシージャの中にありますから 2カ所とも、その次の行に .InitialFileName = "D:¥test¥" の1行を追加してください。もちろん、パスは御自身の環境に合うように変更してくださいね。これで解決してそのままでも結構ですが、ちゃんと理解されてご自身の力にしたいのであれば、コードを読み解いてみてください。理解できるまで何カ月でもお付き合いしますから。（momo） ---- ありがとうございます☆ 勉強したいので、いまひとつずつ解読中ですアドレス指定もできました! これから手作りフォームでもちゃんとできるか試すつもりです。ファイルのコピーもできました! 11月の部分を半角数字（11月）にしたいのですがどこの部分になりますか? なんとなくこのあたりというのはわかるのですが・・・ myMonth = Val(StrConv(StrReverse(Split(StrReverse(myFol), "¥")(0)), vbNarrow)) myMonth = StrConv(Month(DateSerial(Year(Date), myMonth + 1, 1)), vbWide) & "月" また今はコピー先のフォルダがないとファイルが入らないですがフォルダごと作成可能でしょうか? あと、コピー元のファイル名が"9月xxxxxxxxx.xls"じゃなく"xxxx（1109）xxxxx.xls" という、間に年月が入ってるタイプのものもありました。これも対応させるにはどのようにすればいいのでしょうか? まだまだやらなくてはならないところがあり、本ではなかなか載っていないところもあります（＞＜）これからもご教授お願いできますでしょうか? どうぞよろしくお願いします ---- 半角の部分はvbWide⇒vbNarrowに変更しました! ---- If Dir(PastePath, vbDirectory) = "" Then If MsgBox(PastePath & "フォルダがありません。" & vbCr & _ "フォルダを作成しますか?", vbYesNo) = vbYes Then MkDir PastePath Else MsgBox "キャンセルされました" Exit Sub End If End If この部分でフォルダーが無ければ作るようにしていますが出来ませんでしたか? >半角の部分はvbWide⇒vbNarrowに変更しました! これは自力解決できたのですね^^ >あと、コピー元のファイル名が"9月xxxxxxxxx.xls"じゃなく"xxxx（1109）xxxxx.xls" >という、間に年月が入ってるタイプのものもありました。ん〜と色々なタイプがあるとなるとそれぞれにコードで対応させるためにはきちんとしたファイル名のルールが必要ですね。今は、コピーしながらリネームさせてますから最初に全部コピーしてからリネームするようにしたほうが良いのかもしれません。私が書いたコードではTextBox3と4に入れたものが置換されますが複数ある場合に、どのようなインターフェースで対応させたいですか? それともルールは固定ですか? というように、コードを書く時は色々な事を想定して書かないといけないんですよね。イレギュラーな事をどこまで想定して、どのように対応させるかという決めごとを少し考えてみてください。今後役に立ちますから（momo） ---- いろいろありがとうございます。コメントいただいてから少しまとめて考えてみました。今ユーザーフォームは momoさんのとおりに作りなおしました。この方がフォルダを自分で指定できますし、年月が変わっても関係なくできます。やはり、フォルダがない場合はフォルダを作成せず、その場所にファイルだけコピーされてしまう状態です。また、置き換え後（TextBox3と4）にはファイル名がでるかと思っていたのですがフォルダ名10月（TextBox3）11月（TextBox4)という風にでます。できれば、ファイル名が一覧で出てくれるとありがたいです。インターフェースはこのままで行きたいと思います（^^） ---- ファイル名を表示させるのであれば、TextBoxではなくListBoxを使ってみてはどうでしょう? 左側に現在のフォルダのファイルを一覧表示させて置換ボタンで右側のListBoxに置換後のファイル一覧を表示置換もTextBoxでどの文字をどのように置換するかを指定させるようにしてそうすればどんなイレギュラーな日付でも対応できますし。で、すべて確認後に一括コピーとかそんな仕様はどうでしょうか? それでよければ、ちょっと時間をもらえればサンプルコード書いてみます。いずれにしても、ここから先は細かい仕様をどう作りこんでいくかという方向になりますから色々な場面を考えてみてください。（momo） ---- お世話になります。 ListBox使ったことがないので、ぜひ試してみたいです。ファイル名の確認をしたのですが、"9月xxxxxxxxx.xls"タイプと"xxxx（1109）xxxxx.xls"の 2種類だけのようです。ですが今後絶対とは言い切れないので、イレギュラーなものに対応できたらうれしいです。ファイル名の変換ができたあと、今度はコピー元の（前月）ファイルからコピー先（今月）へ決まった列へ数値のコピーして張り付けたり、空白にしたりという作業があります。リンクしている数式も今月ファイルのものへ変換させたいのですが実際できるのかよくわかりません。。それをどのタイミングでやればいいのか、その他ご指導頂ければと思います。フォームはこうでなければダメとかはありませんので適宜変えても大丈夫ですよろしくおねがいします（vv） ---- ちょっと手間を取る時間が無いので少し時間をください。あと、追加の分については可能かどうかで言えば可能です。全てのファイルの中を変更するのであればどのようなパターンでどこをどのように変更するのか（全てのファイルが同じではないですよね?それがファイル名とかで解るのかという事です）そのようなルールとか仕様とか呼ばれるものを、つらつらと書いてみてください。それがコーディングの第一歩です。（momo） ---- お忙しいのに、お時間頂いて申し訳ございません。。内容を変更するファイルは決まっています。今自宅なのでファイル数があいまいですが、10個中7個ぐらいの割合だったと思います。たとえば、コピー元（前月）のK列をコピー先（当月）J列にペーストしてそのコピー先のK列は空白にします。損益計算書のような表3つ縦にならんでおり、 K列が今月、J列が先月のデータとなっているのでそのような作業をしたいのです。貼りつけるものは数値で値貼り付けです。間にSUMや率の数式が入っているので、値貼り付けする行はとびとびですがセルは決まっています。そしてすべてのファイルが同じフォーマットなので作業は共通となります。金曜日、会社へ行きましたら列と行、フォーマット等の具体的なものをまとめてまいります。よろしくおねがいします。 ---- うまくお伝えできるかわかりませんが、お目を通して頂けますでしょうか? ファイルをコピーした後の作業から書きます。 @リンク先の更新（すべてのファイル共通）＜作業＞リンク先のファイルはコピー元（先月）のファイルからリンクになっておりこの2種類のファイル名"9月xxxxxxxxx.xls"、"xxxx（1109）xxxxx.xls"を今月に変更 Aコピー、値貼り付け（決められたファイル）この作業を行うファイルは13個中9個です。 "xxxx（1109）xxxxx.xls"タイプの2ファイルのみ複数ワークシートがあり、フォームはすべて共通＜作業＞・コピーしたファイルより、K、V、AG（列）→コピー・左どなり列、J、U、AF（列）→値貼付け・貼り付けが終わったら、K、V、AG（列）→Delete 上記列は行がきまっています。 7〜8、11〜13、17〜29、38〜39、51〜53、55〜60、65〜73行（行の間は空白だったりSUM関数が入っています） B項目に表示されている月を変更下記はセルを表しています。当月以降は、セルの結合をしています。そのセル入るのは、11月のファイルの場合、10月（前月）、11月（当月） 12月（翌月）、1月（翌々月）と月名になります。ーーセルの場所ーーー前月 E5 E49 E81 当月 G5-P5 G49-P49 G81-P81 翌月 R5-AA5 R49-AA49 R81-AA81 翌々月 AB5-AG5 AB49-AG49 AB881-AG81 作業内容を書きましたが、説明不足なところなどご指摘ください。 Aなどは、ファイルをどのように指定すればいいのか。実行中はプログレスバーを出したい。・・・自分ではできないのですが、このような疑問だらけです。ご指導宜しくお願いいたします。 ---- えっと、フォームの部分はまだ置いておいてプログレスバーも、ちょっと置いておきましょう。ファイルコピーした後の作業という部分ですが 1つ1つ部分的に考えてコードにしてみましょう。 1.対象ファイルを開くこれはどのファイルが対象であるかをチェックしながら開く作業・ファイルのルールによって開く必要がある・全てのファイル? ・13個中9個はどのように判別する? というルールを決めてください。あと、ファイルを開くという作業をマクロの記録を取ってみてください。 2.コピー値貼り付けの部分ほとんどマクロ記録で取れると思うのでそれを成形していく作業まずは1度その作業を記録を取ってみましょう 3.項目に表示されている月を変更これは言われている事の意味が良くわかりません。セル範囲についてもわかりにくいです。 A1:C10などの書き方にしてください。ゆっくりですが確実に進めていきましょう。（momo） ---- 時間が空いてしまって申し訳ございません。 1.対象ファイルを開く・全てのファイル?⇒コピぺ作業は13個中9個のファイルです。・13個中9個はどのように判別する?⇒ファイル名で判別できますが、ファイル名の月が毎月変動ファイルを開く作業のマクロはこんなカンジでいいでしょうか? Sub Macro1() ChDir "D:¥temp¥練習用¥10月" Workbooks.Open Filename:= _ "D:¥temp¥練習用¥10月¥Test_PL（1110）_部別.xls", UpdateLinks _ :=0 Workbooks.Open Filename:= _ "D:¥temp¥練習用¥10月¥10月Test_PL_製造.xls", UpdateLinks:=0 _ , Notify:=False End Sub 2.コピー値貼り付けの部分 Sub Macro2() Range("K7:K8").Select Application.CutCopyMode = False Selection.Copy Range("J7:J8").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False MsgBox "コピーペおわり" Range("K7:K8").Select Application.CutCopyMode = False Selection.ClearContents MsgBox "削除おわり" 3.項目に表示されている月を変更ここは、表の一番上になる項目の部分になります。 3つ縦に表がならんでおります。最初は、E5の数字だけかえて、10月は=E5+1でいいかなと思っていましたが、年を越えたとき、13月になってしまう?となりまして・・・ 9月（先月）のみ、1行で構成されており、あとの月はセルの結合になって月を表示しています。（先月、当月、翌月、翌々月がこのセルにはいります。） 9月 E5 E49 E81 10月 F5:P5 Q5:AA5 AB5:AL5 11月 F49:P49 Q49:AA49 AB49:AL49 12月 F81:P81 Q81:AA81 AB81:AL81 表自体は、こんなカンジで、それぞれの月の今回と前回のところを作業していきたいところです。下記は10月まで記載いたしました。 B C D E F G H I J K L M N O P 5 9月 10月 6 実績予算予算計 2Q見通し 3Q見通し前回今回差異差異 2Q差異 3Q差異差異 7 売上高 0 0 0 0 0 0 0 0 0 8 売上原価 0 0 0 0 0 0 0 0 0 9 粗利 0 0 0 0 0 0 0 0 0 0 0 0 10 率 0 0 0 0 0 0 0 0 0 0 0 0 11 ・・・ 0 0 0 0 0 0 0 0 0 うまくご説明できずに申し訳ございません。。どうぞよろしくお願いします ---- >ファイル名で判別できますが、ファイル名の月が毎月変動どのようなルールで判別できますか? >ファイルを開く作業のマクロはこんなカンジでいいでしょうか? 開くだけなら良いのですが、開いてデータを修正して・・・となるのでまだそのコードは置いておきましょう。 > 2.コピー値貼り付けの部分は、以下のように整理できますね。変数の部分を開いたブックに合わせられるようにくっつけていきます。 Sub Macro2() Dim 開いたブック As Workbook Dim 整理したいシート As Worksheet With 開いたブック.整理したいシート .Range("J7:J8").Value = .Range("K7:K8").Value .Range("K7:K8").ClearContents End With End Sub 3は・・・すみません。ちょっと説明だけでは状態がわかりません。もう少し説明お願いします。または実際にデータを手で直す作業をマクロ記録を取ったものを張り付けてもらっても大丈夫です。（momo） ---- ご説明がうまくできずすみません。。（＞＜）セルの結合部分は省きましたが、ファイルをコピー後、 B5〜E5の現在月をもとに先月、当月、来月、再来月のように変わってほしいのです。。 B5に先月を入力すると・・・（本当は入力せずに変わってほしいです） B C D E 5 9月 10月 11月 12月このように変わります。 B C D E 5 10月 11月 12月 13月マクロではなく、数式で対応したほうがいいでしょうか? Sub Macro3() Range("B3:E3").Select Selection.NumberFormatLocal = "#""月""" Range("C3").Select ActiveCell.FormulaR1C1 = "=+RC[-1]+1" Range("D3").Select ActiveCell.FormulaR1C1 = "=+RC[-1]+1" Range("E3").Select ActiveCell.FormulaR1C1 = "=+RC[-1]+1" Range("E4").Select End Sub ---- いえ、それだけなら Sub test() Dim r As Range For Each r In Range("B5:E5") r.Value = r.Value Mod 12 + 1 Next r End Sub 程度で可能なんですけど。まずはファイルを開かないと始まらないので >ファイル名で判別できますが、ファイル名の月が毎月変動どのようなルールで判別できますか? この回答を優先して頂きたいと思っています。たとえば●●という文字がファイル名に含まれているとか A1セルに△△という文字があるファイルとかなにか決まったルールがありますでしょうか? （momo） ---- こんばんは、早速ありがとうございます! セルの結合していても、範囲を指定すれば大丈夫ですか? （自宅に戻り確認できなくて申し訳ございません。。） For Each r In Range("B5:E5") コピー&ペーストする作業を含めすべての作業は一番冒頭の方で、先月から今月へファイルをコピーでできたものを編集していきます。このコピペする対象ファイルは、すべてのワークシートが同じフォームなので上記であげましたB5に必ず先月の月が入っています。ファイル名は、毎月同じものになりますが、すべてに共通するものがありません。。明日、会社にてもう一度確認してみます。 ---- ファイル名をリネームするにしても、特定のファイルだけデータを処理するにしてもファイル名を一定の規則で保存する。というユーザーの認識も大切な要素だと思います。色々なパターンに対応させようと思うとそれだけで大変なコードになりますから。一度、その辺も含めて検討してみてください。仕様が固まったらサンプルコードは書いてみますので。（momo） ---- ファイル名ですが、相談して変えてもらったのですが、コピー作業を行わないファイルもすべて共通して"10月"という文字が入っています。それではダメですよね・・・ "xxxx（1110）xxxxx.xls"このパターンのファイル名をすべて"10月xxxxxxxxx.xls" 月から始まるものに変えました。 ---- まず、その変更は非常に効果的です。ファイル名を翌月に変更するのが楽になりますね^^ で、次はコピー作業を行うファイルの決まり事ですがファイル名でわからないとすると、ミニーさんはどのようにしてそのファイルを特定していますか? その判断する決め手をプログラム化すれば良いのでそのキーポイントを教えてください。（momo） ---- 私が判断しているのは、月のところ以外はきまった名前なのでファイル名ごと覚えているようなカンジです。コピー作業を行わないファイルにも、なにか区別するようなものを付けた方がいいでしょうか? ある程度は、こちらにあわせて変えていいと言ってもらったので大丈夫です♪ ---- コピー作業が必要なファイルに特定の文字を付けて頂いても良いですし、多少処理時間はかかりますが、あるシートのあるセルに特定のデータがあるなどでも構いません。ファイル名が決まっているなら、そのファイル名を羅列しても大丈夫です。（momo） ---- ファイルの追加がないとは思いますが、あったときのことを考えて特定の文字を使用したほうがいいでしょうか? たとえば、☆などの記号は使用しないほうがいいでしょうか? ---- ☆でもなんでも大丈夫ですよそれで良ければサンプル書いてみますので少し時間をください。 #ちょっと本業が忙しいので^^; （momo） ---- あ・・・コードを書いていて思ったのですがデータをコピーする作業は最初のシートだけですか? シート名は固定ですか? 違う場合はどのシートか、全てかを教えてください。あと、コピーする作業はK7:K8をJ7:J8にコピーするだけですか? それと、月を+1するセルを正確に教えてください。結合セルの場合はその旨も。（momo） ---- 了解いたしました! それでは、上記まとめてご連絡いたします。お忙しいところお時間頂きましてありがとうございます。急いでおりませんので宜しくお願い致します! ---- こんにちは、その後いかがでしょうか? 私の方は上記の内容以外はコードは書き終えています。特に急ぐ訳ではありませんが、回答お待ちしていますね。（momo） ---- お忙しいところ、ありがとうございます。作業するファイルですがファイルの中にワークシートが1つのものが3つ。ファイルの中にワークシートが複数あり、その中のいくつかが対象。という2パターンのファイルが8つほどあります。ワークシートを選択したり、ファイル名と同じ用に、ワークシートの名前を決まっていればできるのでしょうか? また、セルのコピー、値貼り付け、削除する作業ですが、列で指定できるのか、セルごとの方がいいでしょうか? セルの間に簡単なSum関数や率を求めるような数式の入っているセルもあり、そこは消さずに残しておきたいのですが・・・ ---- >ファイル名と同じ用に、ワークシートの名前を決まっていればできるのでしょうか? なにかしらのルールがあれば出来ます。ファイル名に特定の文字があったり、そのシートの特定のセルに特定の文字があるなどのルールです。 >列で指定できるのか、セルごとの方がいいでしょうか? 途中に結合セルや非表示セルが無ければ列でも大丈夫だと思います。 >セルの間に簡単なSum関数や率を求めるような数式の入っているセルもあり、そこは >消さずに残しておきたいのですが・・・そこを除いてセル範囲でコピペもできますし、全部コピーしてからそのセル以外を消すとかあとは、全部消してからそのセルに計算式をVBAで入れてしまうのでも大丈夫です。その辺は考え方次第なので仕様を決めてみてください。（momo） ---- 早速ありがとうございます! それではワークシートを確認してみます。全部コピーしてからそのセル以外を消すのを選んだ場合は、数式の入っているセル番地を指定するのでしょうか? それを含めてファイル確認してきます（^^） ---- コピーする範囲、消す範囲、それぞれ明確にしてみてください。（momo） ---- 遅くなりました（--;）範囲まとめてきましたので、見て頂けますでしょうか? カッコの中はセル番号ですところどころぬけているところは数式が入っているのでできれば、そのままにしておきたいところです。 @コピー K、V、AG列（K、V、AG7〜8、11〜13、17〜29、38〜39、51〜53、55〜60、65〜73） A貼り付け J、U、AF列（J、U、AF7〜8、11〜13、17〜29、38〜39、51〜53、55〜60、65〜73） B値削除 K、V、AG列（K、V、AG8、11〜13、17〜29、38〜39、51〜53、55〜60、65〜73） 7行目は数式が入っているので、A値貼り付けまではしますが B値の削除はしません。ワークシートが複数ある場合は、ワークシート名が2文字の場合この作業をでした。たとえば"BK"、"WT"のような名前です。これではダメでしょうか? 複数ワークシートがない場合は、名前に決まりはなくシートが1枚しかありません。宜しくお願いします。 ---- わかりました。とりあえず書いてみます。 2,3日忙しいので少し時間をください（momo） ---- 本当にありがとうございます（vv）よろしくおねがいします ---- お待たせしました。新規ブックで試してください。なお、試しにコピーするフォルダのブックは必ずバックアップを取ってから試してください。準備として新規ユーザーフォームに TextBox1〜4 の4個 Label1〜4 の4個 CommandButton1〜3 の3個 ListBox1 の1個を適当に配置してください。例によってコード内で成形します。ユーザーフォームのモジュールに以下を全て貼り付け。で、実行してみてください。・コピー元フォルダの参照ボタンだけで、基本項目はすべてリストアップされます。・置換文字を全て変更する場合は置換ファイル名、置換後ファイル名を変更すると全て変更されます。・イレギュラーなファイルがある場合はListBoxのファイル名を選択すれば個別に変更出来ます。複雑なコードに見えるかもしれませんが、とっても簡単な基本的な事の組合せだけで実現しています。ゆっくり見ていけばすぐに理解できるはずですから、これで出来たとしても継続して勉強してください。 ====以下コード==== Option Explicit Private Const 初期フォルダ As String = "D:¥test¥" Private Const 作業マーカー As String = "☆" Private Sub UserForm_Initialize() With Me .Height = 280 .Width = 290 With .Label1 .Caption = "コピー元フォルダ" .Top = 6 .Left = 12 .Height = 12 .Width = 60 End With With .Label2 .Caption = "コピー先フォルダ" .Top = 42 .Left = 12 .Height = 12 .Width = 60 End With With .Label3 .Caption = "置換ファイル名" .Top = 84 .Left = 12 .Height = 12 .Width = 70 End With With .Label4 .Caption = "置換後ファイル名" .Top = 84 .Left = 130 .Height = 12 .Width = 70 End With With .TextBox1 .Top = 18 .Left = 12 .Height = 18 .Width = 200 End With With .TextBox2 .Top = 54 .Left = 12 .Height = 18 .Width = 200 End With With .TextBox3 .Top = 96 .Left = 12 .Height = 18 .Width = 80 End With With .TextBox4 .Top = 96 .Left = 130 .Height = 18 .Width = 80 End With With .CommandButton1 .Caption = "参照" .Top = 18 .Left = 220 .Height = 18 .Width = 50 End With With .CommandButton2 .Caption = "参照" .Top = 54 .Left = 220 .Height = 18 .Width = 50 End With With .CommandButton3 .Caption = "コピー開始" .Top = 96 .Left = 220 .Height = 18 .Width = 50 End With With .ListBox1 .ColumnCount = 2 .Top = 130 .Left = 12 .Height = 120 .Width = 260 End With End With End Sub Private Sub CommandButton1_Click() Dim myFol As String Dim myPath As String Dim myMonth As String myFol = GetFolderPath If myFol Like "*月" Then Me.TextBox1.Value = myFol myPath = StrReverse(Split(StrReverse(myFol), "¥")(0)) Me.TextBox3.Value = myPath myMonth = Val(StrConv(StrReverse(Split(StrReverse(myFol), "¥")(0)), vbNarrow)) myMonth = Month(DateSerial(Year(Date), myMonth + 1, 1)) & "月" Me.TextBox4.Value = myMonth Me.TextBox2.Value = Replace(myFol, myPath, myMonth) End If End Sub Private Sub CommandButton2_Click() Me.TextBox2.Value = GetFolderPath End Sub Private Sub CommandButton3_Click() Dim CopyPath As String Dim PastPath As String Dim CopyFile As String Dim PastFile As String Dim i As Long Dim ws As Worksheet CopyPath = Me.TextBox1.Value PastPath = Me.TextBox2.Value If CopyPath = "" Or PastPath = "" Then MsgBox "フォルダが指定されていません" Else 'フォルダチェック&作成 If Dir(PastPath, vbDirectory) = "" Then If MsgBox(PastPath & "フォルダがありません。" & vbCr & _ "フォルダを作成しますか?", vbYesNo) = vbYes Then MkDir PastPath Else MsgBox "キャンセルされました" Exit Sub End If End If 'ファイルコピー&リネーム Application.ScreenUpdating = False With Me.ListBox1 For i = 0 To .ListCount - 1 CopyFile = CopyPath & "¥" & .List(i, 0) PastFile = PastPath & "¥" & .List(i, 1) If .List(i, 0) Like "*" & 作業マーカー & "*" Then With Workbooks.Open(CopyFile) If .Worksheets.Count = 1 Then CopyWork .Name, .Worksheets(1).Name Else For Each ws In .Worksheets If Len(ws.Name) = 2 Then CopyWork .Name, ws.Name End If Next ws End If .SaveAs PastFile .Close False End With Else FileCopy CopyFile, PastFile End If Next i End With Application.ScreenUpdating = True MsgBox "作業完了" End If End Sub Private Sub TextBox1_Change() SetFileList End Sub Private Sub TextBox2_Change() SetFileList End Sub Private Sub TextBox3_Change() SetFileList End Sub Private Sub TextBox4_Change() SetFileList End Sub Private Sub ListBox1_AfterUpdate() Dim buf As Variant With Me.ListBox1 If .Tag = "" Then If MsgBox("個別修正しますか?", vbYesNo) = vbYes Then buf = Application.InputBox("ファイル名を修正してください。" & vbLf & vbLf & _ .List(.ListIndex, 0), , .List(.ListIndex, 1)) If VarType(buf) <> vbBoolean Then .List(.ListIndex, 1) = buf End If End If .Tag = "Rename" .ListIndex = -1 Else .Tag = "" End If End With End Sub Private Sub SetFileList() Dim myFile As String Dim myC As New Collection Me.ListBox1.Clear With Me.TextBox1 If .Value <> "" Then myFile = Dir(.Value & "¥*.xls*") Do Until myFile = "" With Me.ListBox1 .AddItem .List(.ListCount - 1, 0) = myFile .List(.ListCount - 1, 1) = Replace(myFile, Me.TextBox3.Value, Me.TextBox4.Value) End With myFile = Dir() Loop End If End With End Sub Private Function GetFolderPath() As String With Application.FileDialog(msoFileDialogFolderPicker) .InitialFileName = 初期フォルダ If .Show = True Then GetFolderPath = .SelectedItems(1) End If End With End Function Private Sub CopyWork(strWB As String, strWS As String) Dim myArea As Range Dim myCol As Variant With Workbooks(strWB).Worksheets(strWS) For Each myArea In .Range("K7,V7,AG7").Areas myArea.Offset(, -1).Value = myArea.Value Next myArea For Each myArea In .Range("8:8,11:13,17:29,38:39,51:53,55:60,65:73").Areas For Each myCol In Array("K", "V", "AG") With myArea.Columns(myCol) .Offset(, -1).Value = .Value .ClearContents End With Next myCol Next myArea End With End Sub （momo） ---- 早速ありがとうございます。本当にすごいですね! いまひとつひとつ意味を考えながらやっています。実行したところ下記ができませんでした。こちらで何か手順が違うのかもしれません。。 @新しいフォルダが作成されない（ファイルは大丈夫でした） Aコピーの貼付け、クリアあと、作成されるファイルの中でファイルのリンクがありファイルが開くたびにリンク更新のメッセージがでてきます。ここはどうすればいいでしょうか? できれば、ファイル内のリンクも10月から11月に変えたいのですが可能でしょうか? （リンク先ファイルも、この作成ファイルです。）よろしくおねがいします。 ---- >1.新しいフォルダが作成されないん〜こちらでは作成されますが・・・ちなみに保存場所はどこでしょうか? OSのバージョンは? >2.コピーの貼付け、クリアファイル名に「☆」は付いていますか? シート名は2文字ですか?スペースなどはありませんか? ファイルのリンクについては、もう少し詳細を教えてください。（momo） ---- ●1.新しいフォルダが作成されない momoさんが作成されるのでしたら、私が何か間違っているのだと思います。 OSはXPで、Officeは2003です。保存場所はとりあえず自分のDドライブにフォルダを作ってやっています。コピー元:D:¥temp¥10月コピー先:D:¥temp ●2.コピーの貼付け、クリアカンジンなことを言っておりませんでした。 ☆がついているものが除外になります。。 ☆以外のファイルがコピーなどの作業対象です。本当に申し訳ございません（TT） ---- コピー元:D:¥temp¥10月なら、コピー先は D:¥temp¥11月になりませんか? D:¥temp では元々の親フォルダですから存在するので作成されませんね。 ☆以外ですか、失礼しました。コード内の > If .List(i, 0) Like "*" & 作業マーカー & "*" Then という所があるので If Not .List(i, 0) Like "*" & 作業マーカー & "*" Then ‾‾‾と、Notを追加してください。（momo） ---- フォルダは解決しました! 私が手作業で選択しなおしていたため作成されなかったみたいです。それと申し訳ございません。値貼付けする位置が隣の列ではなく、-12個ずれました。 V列をコピーして、それをJ列にペースト AG列をコピーして、それをU列にペーストその後空白にするのは、K,V,AF,AGです。下記辺りからだというのはなんとなくわかるのですが、怖くてさわれません・・・ For Each myArea In .Range("K7,V7,AG7").Areas myArea.Offset(, -1).Value = myArea.Value コピーの作業もできていました! これからまた全部ファイル確認してみます! ---- ん? フォルダはOK、ファイルのコピーもOKですね? あとは値の貼り付け位置が違うという事でしょうか? K列とAF列はコピーせずに消してしまって良いという事ですか? あと、行番号は変わらないですね? という条件だとしたら CopyWorkプロシージャを丸々以下と入れ替えてみてください。 Private Sub CopyWork(strWB As String, strWS As String) Dim myArea As Range Dim myCol As Variant With Workbooks(strWB).Worksheets(strWS) For Each myArea In .Range("7:8,11:13,17:29,38:39,51:53,55:60,65:73").Areas For Each myCol In Array("V", "AG") With myArea.Columns(myCol) .Offset(, -12).Value = .Value End With Next myCol Next myArea For Each myArea In .Range("8:8,11:13,17:29,38:39,51:53,55:60,65:73").Areas For Each myCol In Array("K", "V", "AF", "AG") With myArea.Columns(myCol) .ClearContents End With Next myCol Next myArea End With End Sub （momo） ---- はい、フォルダ、ファイルOKでした! あと、K列とAF列コピーしませんので、入替えましたらできました! 個々のファイルにあるリンク先の更新は、手作業でやるしかないのでしょうか? それと未熟でおはずかしいのですが、教えてください。。。ワークシートが複数あって、コピー作業をするのはワークシート名が2文字の場合は・・・というのはコードのどの部分でしょうか? ひとつひとつ調べながらですが、理解できるよう苦戦してます（--;） ---- >コピー作業をするのはワークシート名が2文字の場合は・・・というのは >コードのどの部分でしょうか? これは以下の部分ですね。 If Len(ws.Name) = 2 Then シート名の文字の長さが2の時に・・・という分岐条件をしています。 >できれば、ファイル内のリンクも10月から11月に変えたいのですが可能でしょうか? の件は >ファイルのリンクについては、もう少し詳細を教えてください。と回答していますが、もう少し詳細に教えてください。・リンクとはどんなリンクなのか・具体的なセル位置と参照先・置換のルールなどたとえば、変更するリンク部分は何をさしていますか? パスですか?ブック名ですか?シート名ですか? Ctrl+Fの置換で出来る内容ですか? （momo） ---- 早速ありがとうございます! なんとなくしかわからないのでまたコードでわからないところがあったら教えてください（vv）・リンクとはどんなリンクなのか >コピー元のフォルダに入っている先月ファイルになっています。・具体的なセル位置と参照先 >いろんなセルに入っています。すべて確認した方がいいでしょうか? ・置換のルールなど >10月xxxxxxxxx.xlsのファイルなので、11月（翌月）に直します。 Ctrl+Fでリンクファイルを検索すると一覧ででてきたので、置換えもできそう??です。明日置換えできるか試してみます! ---- Ctrl+Hで置換窓を出してオプションを押して検索場所をシートからブックに検索対象を数式にしておいて検索する文字列に「10月」置換後の文字列に「11月」で、全て置換で望み通りになりますか? なるのであれば、それをコードにするだけですので簡単です。（momo） ---- momoさま、大変申し訳ございません。。 If Len(ws.Name) = 2 Then シート名の文字の長さが2の時に・・・ですが @どうしても2文字にできないシートがいくつかあり B7セルが"売上"という文字列のもののみを対象にコピー作業をするように変更お願いできますでしょうか? Aセルの値をクリアにするところですが値のみをクリアにするのは可能でしょうか? 数式がはいっているものは削除したくないのですが今のままで対応できるものと、ファイルによってセルに数式が入っているものがあり、下記の指定だけではできなくなってしまいました。。 For Each myArea In .Range("8:8,11:13,17:29,38:39,51:53,55:60,65:73").Areas For Each myCol In Array("K", "V", "AF", "AG") Bリンクは置換えでできました。ファイル名が10月から11月に置換えするだけで大丈夫でした。最初のファイルコピーのものがすべて対象になります。 Cファイルコピーの作業ですが、フォームが違うものが2つあります。すべてあわせてくださいとお願いしたのですが、この2つだけはできませんでした。どうすればよろしいでしょうか・・・できるだけmomoさんのご教授にそってやりたいと思っていますのでよろしくおねがいします。 ---- 1.If Len(ws.Name) = 2 Then の部分を If ws.Range("B7").Value = "売上" Then に変更してみましょう。 wsという変数でシートをループしていて、そのシートのB7セルが"売上"の場合という意味になります。 2と3は、以下をまるっと差し替えどこが違うか確認してください。 Private Sub CopyWork(strWB As String, strWS As String) Dim myArea As Range Dim myCol As Variant Dim myRng As Range With Workbooks(strWB).Worksheets(strWS) For Each myArea In .Range("7:8,11:13,17:29,38:39,51:53,55:60,65:73").Areas For Each myCol In Array("V", "AG") With myArea.Columns(myCol) .Offset(, -12).Value = .Value End With Next myCol Next myArea For Each myArea In .Range("7:8,11:13,17:29,38:39,51:53,55:60,65:73").Areas For Each myCol In Array("K", "V", "AF", "AG") For Each myRng In myArea.Columns(myCol).Cells If myRng.HasFormula = False Then myRng.ClearContents End If Next myRng Next myCol Next myArea .Cells.Replace Me.TextBox3.Value, Me.TextBox4.Value, xlPart, xlByRows End With End Sub 4.は・・・どのように何が違うのかを明確にしてみてください。（momo） ---- momoさまありがとうございます! できあがる直前で変更になってしまい、不愉快にさせてしまうのでは…と心配でした。 4についてですが作業自体は、コピーして貼り付け、セルのクリアと同じなのですが、作業列が違います。ワークシート名と、列の詳細を明日まとめてまいります。お手間おかけしますがよろしくおねがいします。。 ---- セルの範囲も細かく必要ですが、それ以上に必要なのがそのイレギュラーファイルを特定するポイントです。 ☆がついていないファイルの中から、その特定の2ファイルだけを見分けるルールを決めてくださいね。（momo） ---- 遅くなりました。すみません! まとめてみましたので、お時間ありましたらお願いします＜コピー作業をするシート＞ @シート名が”差額” Aシート名が”システム” Bシート名が”会社差額” C上記以外のシート⇒すでに対応ずみのものです。 ●コピー作業の詳細 @シート名が”差額” R列をコピーして、Eへ値貼付け AC列をコピーして、Qへ値貼付けその後、F、R、AC列を数式以外のセルをクリア行番号は（7:8、11:13、17:29、38:39、43、51:53、55:60、65:73） ※D7セルが売上高から始まりますが、このシート名を優先になるようにお願いできますか? ※このファイルの中には、Cのものも混ざっています。 Aシート名が”システム” K列をコピーして、Dへ値貼付け Q列をコピーして、Jへ値貼付けその後、E、K、P、Q列を数式以外のセルをクリア行番号（4:27、34:57、64:88、95:119、155:170、179:190、198:208、217:224、233:240、249:262、270:273） Bシート名が”会社差額”⇒コピー作業などはなく何もしない。除外 C上記以外のシート ⇒済み（D7が売上で始まるもの）何か説明が不明なところなどあれば、ご指摘ください。よろしくお願いします ---- 少し質問です。処理順に 1.ファイル名に☆が無ければ質問1:これは変わらず? 2.シートが1つならシート名やセルに関わらず必ず丸4を実行質問2:これは変わらず? 3.シート名が差額なら丸1を実行（丸付き数字は使いません） 4.シート名がシステムなら丸2を実行 5.シート名会社差額はセルに「売上」があったとしても除外 6.それ以外でD7セルが売上で始まるものは前回の処理質問3:セルがB7からD7に変更になったのですか? 質問4:セルの内容が「売上」ではなく、「売上」から始まるもの? つまり「売上だよ〜」でも実行? 以上、処理手順の確認と4つの質問に回答お願いします。（momo） ---- 処理順はこれで大丈夫です 1.ファイル名に☆が無ければ質問1:これは変わらず? ⇒はい、変わりません 2.シートが1つならシート名やセルに関わらず必ず丸4を実行質問2:これは変わらず?⇒はい、変わりません。 3.シート名が差額なら丸1を実行（丸付き数字は使いません）⇒はい、丸1実行です。 4.シート名がシステムなら丸2を実行⇒はい、その通りです。 5.シート名会社差額はセルに「売上」があったとしても除外 6.それ以外でD7セルが売上で始まるものは前回の処理質問3:セルがB7からD7に変更になったのですか?⇒すみません、間違えました!B7セルです。質問4:セルの内容が「売上」ではなく、「売上」から始まるもの? つまり「売上だよ〜」でも実行? ⇒それでは、”売上高”という3文字で、固定してもらえますか? ---- では、変更場所が多いので全部差し替えで。ただ、すみません・・・テストしてる時間が無いので完全に頭の中だけで書きましたので、デバッグやエラーが表示されたら教えてください。 Option Explicit Private Const 初期フォルダ As String = "D:¥test¥" Private Const 作業マーカー As String = "☆" Private Sub UserForm_Initialize() With Me .Height = 280 .Width = 290 With .Label1 .Caption = "コピー元フォルダ" .Top = 6 .Left = 12 .Height = 12 .Width = 60 End With With .Label2 .Caption = "コピー先フォルダ" .Top = 42 .Left = 12 .Height = 12 .Width = 60 End With With .Label3 .Caption = "置換ファイル名" .Top = 84 .Left = 12 .Height = 12 .Width = 70 End With With .Label4 .Caption = "置換後ファイル名" .Top = 84 .Left = 130 .Height = 12 .Width = 70 End With With .TextBox1 .Top = 18 .Left = 12 .Height = 18 .Width = 200 End With With .TextBox2 .Top = 54 .Left = 12 .Height = 18 .Width = 200 End With With .TextBox3 .Top = 96 .Left = 12 .Height = 18 .Width = 80 End With With .TextBox4 .Top = 96 .Left = 130 .Height = 18 .Width = 80 End With With .CommandButton1 .Caption = "参照" .Top = 18 .Left = 220 .Height = 18 .Width = 50 End With With .CommandButton2 .Caption = "参照" .Top = 54 .Left = 220 .Height = 18 .Width = 50 End With With .CommandButton3 .Caption = "コピー開始" .Top = 96 .Left = 220 .Height = 18 .Width = 50 End With With .ListBox1 .ColumnCount = 2 .Top = 130 .Left = 12 .Height = 120 .Width = 260 End With End With End Sub Private Sub CommandButton1_Click() Dim myFol As String Dim myPath As String Dim myMonth As String myFol = GetFolderPath If myFol Like "*月" Then Me.TextBox1.Value = myFol myPath = StrReverse(Split(StrReverse(myFol), "¥")(0)) Me.TextBox3.Value = myPath myMonth = Val(StrConv(StrReverse(Split(StrReverse(myFol), "¥")(0)), vbNarrow)) myMonth = Month(DateSerial(Year(Date), myMonth + 1, 1)) & "月" Me.TextBox4.Value = myMonth Me.TextBox2.Value = Replace(myFol, myPath, myMonth) End If End Sub Private Sub CommandButton2_Click() Me.TextBox2.Value = GetFolderPath End Sub Private Sub CommandButton3_Click() Dim CopyPath As String Dim PastPath As String Dim CopyFile As String Dim PastFile As String Dim i As Long Dim ws As Worksheet CopyPath = Me.TextBox1.Value PastPath = Me.TextBox2.Value If CopyPath = "" Or PastPath = "" Then MsgBox "フォルダが指定されていません" Else 'フォルダチェック&作成 If Dir(PastPath, vbDirectory) = "" Then If MsgBox(PastPath & "フォルダがありません。" & vbCr & _ "フォルダを作成しますか?", vbYesNo) = vbYes Then MkDir PastPath Else MsgBox "キャンセルされました" Exit Sub End If End If 'ファイルコピー&リネーム With Me.ListBox1 For i = 0 To .ListCount - 1 CopyFile = CopyPath & "¥" & .List(i, 0) PastFile = PastPath & "¥" & .List(i, 1) If Not .List(i, 0) Like "*" & 作業マーカー & "*" Then CopyProc CopyFile, PastFile Else FileCopy CopyFile, PastFile End If Next i End With MsgBox "作業完了" End If End Sub Private Sub TextBox1_Change() SetFileList End Sub Private Sub TextBox2_Change() SetFileList End Sub Private Sub TextBox3_Change() SetFileList End Sub Private Sub TextBox4_Change() SetFileList End Sub Private Sub ListBox1_AfterUpdate() Dim buf As Variant With Me.ListBox1 If .Tag = "" Then If MsgBox("個別修正しますか?", vbYesNo) = vbYes Then buf = Application.InputBox("ファイル名を修正してください。" & vbLf & vbLf & _ .List(.ListIndex, 0), , .List(.ListIndex, 1)) If VarType(buf) <> vbBoolean Then .List(.ListIndex, 1) = buf End If End If .Tag = "Rename" .ListIndex = -1 Else .Tag = "" End If End With End Sub Private Sub SetFileList() Dim myFile As String Dim myC As New Collection Me.ListBox1.Clear With Me.TextBox1 If .Value <> "" Then myFile = Dir(.Value & "¥*.xls*") Do Until myFile = "" With Me.ListBox1 .AddItem .List(.ListCount - 1, 0) = myFile .List(.ListCount - 1, 1) = Replace(myFile, Me.TextBox3.Value, Me.TextBox4.Value) End With myFile = Dir() Loop End If End With End Sub Private Function GetFolderPath() As String With Application.FileDialog(msoFileDialogFolderPicker) .InitialFileName = 初期フォルダ If .Show = True Then GetFolderPath = .SelectedItems(1) End If End With End Function Private Sub CopyProc(OpenPath As String, SavePath As String) Dim ws As Worksheet Application.ScreenUpdating = False With Workbooks.Open(OpenPath) If .Worksheets.Count = 1 Then CopyWork .Worksheets(1), 3 Else For Each ws In .Worksheets If ws.Name = "差額" Then CopyWork ws, 1 ElseIf ws.Name = "システム" Then CopyWork ws, 2 ElseIf ws.Name <> "会社差額" And ws.Range("B7").Value = "売上高" Then CopyWork ws, 3 End If Next ws End If .SaveAs SavePath .Close False End With Application.ScreenUpdating = True End Sub Private Sub CopyWork(myWs As Worksheet, Ptn As Integer) Dim myArea As Range Dim myCol As Variant Dim myRng As Range Dim strRowRng As String Dim aryCpyRng As Variant Dim aryDelRng As Variant Dim buf As Variant Select Case Ptn Case 1 strRowRng = "7:8,11:13,17:29,38:39,43:43,51:53,55:60,65:73" aryCpyRng = Array("R→E", "AC→Q") aryDelRng = Array("F", "R", "AC") Case 2 strRowRng = "4:27,34:57,64:88,95:119,155:170,179:190,198:208,217:224,233:240,249:262,270:273" aryCpyRng = Array("K→D", "Q→J") aryDelRng = Array("E", "K", "P", "Q") Case 3 strRowRng = "7:8,11:13,17:29,38:39,51:53,55:60,65:73" aryCpyRng = Array("V→J", "AG→U") aryDelRng = Array("K", "V", "AF", "AG") End Select With myWs For Each myArea In .Range(strRowRng).Areas For Each myCol In aryCpyRng buf = Split(myCol, "→") With myArea .Columns(buf(1)).Value = .Columns(buf(0)).Value End With Next myCol Next myArea For Each myArea In .Range(strRowRng).Areas For Each myCol In aryDelRng For Each myRng In myArea.Columns(myCol).Cells If myRng.HasFormula = False Then myRng.ClearContents End If Next myRng Next myCol Next myArea .Cells.Replace Me.TextBox3.Value, Me.TextBox4.Value, xlPart, xlByRows End With End Sub （momo） ---- 短時間で書いて頂いてありがとうございます。早速ためしてみました! すると、当月のファイルを開いて作成している途中でリンク更新のダイアログがでてくのですが、更新しないを選択してうまくいっていたのですが、書き換え後、値の更新というダイアログが開きファイルを選択しなければいけなくなります。それをキャンセルすると何もかたまって操作ができなくなるという現象が起きます。 ---- そうですかぁもう一度リンクについて確認します。リンクの更新は、☆が付いていないブックの全てのシートの全てのセルについて「10月」などのファイル名更新部分を「11月」のように次ぎの月に変更する。という仕様で間違いないですか? その他で更新してはいけない部分や更新しなければ行けない所は無いですか? （momo） ---- お手数おかけします。。リンクの更新は前月の月を当月に変えるで間違いありません。作成するファイル以外はリンクしないようにしたので大丈夫です。よろしくお願いします。 ---- どのようなリンクが張られているのかわからないので推測ですがファイル名を変えながら移行していますからまだ出来ていないファイル名へのリンクがされている可能性がありますね。再計算とメッセージを抑えて・・・以下を差し替えるとどうですか? Private Sub CopyProc(OpenPath As String, SavePath As String) Dim ws As Worksheet With Application .ScreenUpdating = False .Calculation = xlCalculationManual .DisplayAlerts = False End With With Workbooks.Open(OpenPath) If .Worksheets.Count = 1 Then CopyWork .Worksheets(1), 3 Else For Each ws In .Worksheets If ws.Name = "差額" Then CopyWork ws, 1 ElseIf ws.Name = "システム" Then CopyWork ws, 2 ElseIf ws.Name <> "会社差額" And ws.Range("B7").Value = "売上高" Then CopyWork ws, 3 End If Next ws End If .SaveAs SavePath .Close False End With With Application .DisplayAlerts = True .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With End Sub （momo） ---- リンクの更新ですが、☆がついていないファイルも対象でした。ご質問見落としておりました。申し訳ございません（汗）まだ全部確認したわけではないのですが、それ以外は大丈夫そうです。 ---- >リンクの更新ですが、☆がついていないファイルも対象でした。あら・・・ ☆が付いて無いものもという事は、全てのファイル、全てのシートという事ですか? 根本の分岐条件が変わるので明らかにしたいです。（momo） ---- そうなんです。コピー作業のために☆をつけたのですが、そのほかの作業はファイル、シートすべて対象です本当に申し訳ございません!! もし難しいのであれば、手作業の覚悟をします（--;） ---- 特に難しくはないですよ。むしろ簡単になります。ただ、最初からそのように考えるのと、途中からロジックを変更するのでは多少無駄が出たり、コードの流れの考え方に統一性が無くなる事もあるのでご容赦お願いします。以下、すべて差し替えで試してみてください。相変わらず多忙に付き、テストしてません。頭の中で動かしてるのでボケてる所があるかもしれません。^^; Option Explicit Private Const 初期フォルダ As String = "D:¥test¥" Private Const 作業マーカー As String = "☆" Private Sub UserForm_Initialize() With Me .Height = 280 .Width = 290 With .Label1 .Caption = "コピー元フォルダ" .Top = 6 .Left = 12 .Height = 12 .Width = 60 End With With .Label2 .Caption = "コピー先フォルダ" .Top = 42 .Left = 12 .Height = 12 .Width = 60 End With With .Label3 .Caption = "置換ファイル名" .Top = 84 .Left = 12 .Height = 12 .Width = 70 End With With .Label4 .Caption = "置換後ファイル名" .Top = 84 .Left = 130 .Height = 12 .Width = 70 End With With .TextBox1 .Top = 18 .Left = 12 .Height = 18 .Width = 200 End With With .TextBox2 .Top = 54 .Left = 12 .Height = 18 .Width = 200 End With With .TextBox3 .Top = 96 .Left = 12 .Height = 18 .Width = 80 End With With .TextBox4 .Top = 96 .Left = 130 .Height = 18 .Width = 80 End With With .CommandButton1 .Caption = "参照" .Top = 18 .Left = 220 .Height = 18 .Width = 50 End With With .CommandButton2 .Caption = "参照" .Top = 54 .Left = 220 .Height = 18 .Width = 50 End With With .CommandButton3 .Caption = "コピー開始" .Top = 96 .Left = 220 .Height = 18 .Width = 50 End With With .ListBox1 .ColumnCount = 2 .Top = 130 .Left = 12 .Height = 120 .Width = 260 End With End With End Sub Private Sub CommandButton1_Click() Dim myFol As String Dim myPath As String Dim myMonth As String myFol = GetFolderPath If myFol Like "*月" Then Me.TextBox1.Value = myFol myPath = StrReverse(Split(StrReverse(myFol), "¥")(0)) Me.TextBox3.Value = myPath myMonth = Val(StrConv(StrReverse(Split(StrReverse(myFol), "¥")(0)), vbNarrow)) myMonth = Month(DateSerial(Year(Date), myMonth + 1, 1)) & "月" Me.TextBox4.Value = myMonth Me.TextBox2.Value = Replace(myFol, myPath, myMonth) End If End Sub Private Sub CommandButton2_Click() Me.TextBox2.Value = GetFolderPath End Sub Private Sub CommandButton3_Click() Dim CopyPath As String Dim PastPath As String Dim CopyFile As String Dim PastFile As String Dim i As Long Dim ws As Worksheet CopyPath = Me.TextBox1.Value PastPath = Me.TextBox2.Value If CopyPath = "" Or PastPath = "" Then MsgBox "フォルダが指定されていません" Else 'フォルダチェック&作成 If Dir(PastPath, vbDirectory) = "" Then If MsgBox(PastPath & "フォルダがありません。" & vbCr & _ "フォルダを作成しますか?", vbYesNo) = vbYes Then MkDir PastPath Else MsgBox "キャンセルされました" Exit Sub End If End If 'ファイルコピー&リネーム With Me.ListBox1 For i = 0 To .ListCount - 1 CopyProc CopyPath & "¥" & .List(i, 0), PastPath & "¥" & .List(i, 1) Next i End With MsgBox "作業完了" End If End Sub Private Sub TextBox1_Change() SetFileList End Sub Private Sub TextBox2_Change() SetFileList End Sub Private Sub TextBox3_Change() SetFileList End Sub Private Sub TextBox4_Change() SetFileList End Sub Private Sub ListBox1_AfterUpdate() Dim buf As Variant With Me.ListBox1 If .Tag = "" Then If MsgBox("個別修正しますか?", vbYesNo) = vbYes Then buf = Application.InputBox("ファイル名を修正してください。" & vbLf & vbLf & _ .List(.ListIndex, 0), , .List(.ListIndex, 1)) If VarType(buf) <> vbBoolean Then .List(.ListIndex, 1) = buf End If End If .Tag = "Rename" .ListIndex = -1 Else .Tag = "" End If End With End Sub Private Sub SetFileList() Dim myFile As String Dim myC As New Collection Me.ListBox1.Clear With Me.TextBox1 If .Value <> "" Then myFile = Dir(.Value & "¥*.xls*") Do Until myFile = "" With Me.ListBox1 .AddItem .List(.ListCount - 1, 0) = myFile .List(.ListCount - 1, 1) = Replace(myFile, Me.TextBox3.Value, Me.TextBox4.Value) End With myFile = Dir() Loop End If End With End Sub Private Function GetFolderPath() As String With Application.FileDialog(msoFileDialogFolderPicker) .InitialFileName = 初期フォルダ If .Show = True Then GetFolderPath = .SelectedItems(1) End If End With End Function Private Sub CopyProc(OpenPath As String, SavePath As String) Dim ws As Worksheet With Application .ScreenUpdating = False .Calculation = xlCalculationManual .DisplayAlerts = False End With With Workbooks.Open(OpenPath) '値コピー作業 If Not Dir(OpenPath) Like "*" & 作業マーカー & "*" Then If .Worksheets.Count = 1 Then CopyWork .Worksheets(1), 3 Else For Each ws In .Worksheets If ws.Name = "差額" Then CopyWork ws, 1 ElseIf ws.Name = "システム" Then CopyWork ws, 2 ElseIf ws.Name <> "会社差額" And ws.Range("B7").Value = "売上高" Then CopyWork ws, 3 End If Next ws End If End If 'リンク更新作業 For Each ws In .Worksheets ws.Cells.Replace Me.TextBox3.Value, Me.TextBox4.Value, xlPart, xlByRows Next ws .SaveAs SavePath .Close False End With With Application .DisplayAlerts = True .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With End Sub Private Sub CopyWork(myWs As Worksheet, Ptn As Integer) Dim myArea As Range Dim myCol As Variant Dim myRng As Range Dim strRowRng As String Dim aryCpyRng As Variant Dim aryDelRng As Variant Dim buf As Variant Select Case Ptn Case 1 strRowRng = "7:8,11:13,17:29,38:39,43:43,51:53,55:60,65:73" aryCpyRng = Array("R→E", "AC→Q") aryDelRng = Array("F", "R", "AC") Case 2 strRowRng = "4:27,34:57,64:88,95:119,155:170,179:190,198:208,217:224,233:240,249:262,270:273" aryCpyRng = Array("K→D", "Q→J") aryDelRng = Array("E", "K", "P", "Q") Case 3 strRowRng = "7:8,11:13,17:29,38:39,51:53,55:60,65:73" aryCpyRng = Array("V→J", "AG→U") aryDelRng = Array("K", "V", "AF", "AG") End Select With myWs For Each myArea In .Range(strRowRng).Areas For Each myCol In aryCpyRng buf = Split(myCol, "→") With myArea .Columns(buf(1)).Value = .Columns(buf(0)).Value End With Next myCol Next myArea For Each myArea In .Range(strRowRng).Areas For Each myCol In aryDelRng For Each myRng In myArea.Columns(myCol).Cells If myRng.HasFormula = False Then myRng.ClearContents End If Next myRng Next myCol Next myArea End With End Sub （momo） ---- こんにちはお忙しいのかな? あわてずじっくり検証して結果を教えてくださいね。（momo） ---- momoさん、こんにちは。結果のご報告できませんで申し訳ございません。ご連絡しなきゃ、と思いつつ時間がたってしまいました。ローカルにコピーしてやっていたもので(汗）本番前に、変更したファイル名やリンクなどを確認しているところです。また準備ができ実行しましたら、ご連絡申し上げます。 ---- 以前momoさんにお世話になったものです。またmomoさんにお会いできればいいのですが・・・やっと作って頂いたVBAが4月から運用できることになりまして、若干変更部分でてきたので自分あれこれやってみたのですが、どうにもできずご教授いただければと思います。＜変更点＞参照元、参照先のパス、フォルダ名の変更参照元:C:¥2月¥売上販売¥売上販売_2月_確定参照先:C:¥3月¥売上販売¥売上販売_3月_確定参照先の"¥売上販売_3月_確定"は作られていないので、コピー作業時に作成する必要があります。その中にエクセルファイルが格納されていきます。以前は、C:¥2月⇒C:¥3月へコピーでしたので、格納場所がだいぶ奥になってしまいました。 momoさん、VBAのスペシャリストの方どうぞよろしくお願いいたします。 ---- 変更個所は Private Const 初期フォルダ As String = "C:¥" と Private Sub CommandButton1_Click() Dim myFol As String Dim myPath As String Dim myMonth As String myFol = GetFolderPath If myFol Like "*月*" Then Me.TextBox1.Value = myFol myPath = GetMonth(myFol) Me.TextBox3.Value = myPath myMonth = AddMonth(myPath) Me.TextBox4.Value = myMonth Me.TextBox2.Value = Replace(myFol, myPath, myMonth) End If End Sub あとは以下を追加 Private Function GetMonth(myStr As String) As String With CreateObject("VBScript.RegExp") .Global = True .Pattern = "¥d{1,2}月" GetMonth = .Execute(myStr)(0) End With End Function Private Function AddMonth(ByVal myStr As String) As String Dim myReg As Object Dim myMonth As Integer With CreateObject("VBScript.RegExp") .Global = True .Pattern = "¥d{1,2}月" For Each myReg In .Execute(myStr) myMonth = Val(myReg.Value) myMonth = Month(DateSerial(Year(Date), myMonth + 1, 1)) myStr = .Replace(myStr, myMonth & "月") Next myReg End With AddMonth = myStr End Function で、どうでしょうか? 最近多忙で細かく解説できなくてすみません。（momo） ---- momoさまお忙しいところ、回答頂き本当にありがとうございます。試してみたところ、ファイルのコピーできました! 参照先のフォルダが作成される際、月を翌月にすることは可能でしょうか? 現在は、参照元も参照先のフォルダとも"売上販売_2月_確定"と同じフォルダ名がになっています。参照元:C:¥2月¥売上販売¥売上販売_2月_確定参照先:C:¥3月¥売上販売¥売上販売_3月_確定 ⇒翌月にしたい。ファイルの方はすべて翌月でコピーされていました（^^）お時間あるときでかまいませんので、宜しくお願いいたします ---- 上記こちらの勘違いでした。申し訳ございません。（^^;）あともうひとつご相談です・・・コピー作業をしないように、作業マーカー"■"をファイル名につけていましたが、 Listボックスで複数選択したものをセルのコピー&ペースト作業をしないようにできますか? 今は個別にファイル名を変更できるようになっています。何か除外ボタンみたいを増やしてもいいので、何かご提案いただければと思います。ファイル自体のコピーは翌月の名前をつけて必要となります。 ---- すみませんが、ほとんど時間が取れないので・・・とりあえずは、ファイル名の変更で作業マーカーを付けて頂く事でお茶を濁してください。一番簡単な方法でご自身でもくめるかな?と思うのは・ボタンでもなんでも良いので作業マーカーを付ける・ファイル保存時に作業マーカーを消すという段取りで組むのが簡単だと思います。 ListBoxにオプションボタンを付けて判定でも良さそうですね。できればここまでの課程で得られた事を参考に少し頑張ってみてください。決して見捨てるような事は致しませんので。とりあえず今は私の仕事を早めに片付けます。 #本来の仕事では無いのですが少しだけ大きめのシステム作ってます。 #8000ステップくらいのコードになりそうな・・・^^; （momo） ---- お忙しいところ、お返事ありがとうございます。 ListBoxの中でオプションボタンをつけて判定”が自由度があってよさそうですよねそこまでできるかやってみます（^^） ---- momoさん ListBoxにチェックボックスだけつけられました。恥ずかしながら、これも1時間ぐらい考えました（--;） Private Sub UserForm_Initialize() With Me With .ListBox1 .ColumnCount = 2 .ListStyle = fmListStyleOption .MultiSelect = fmMultiSelectMulti End With End With End Sub ですが、個別のファイル名修正ができなくなり、チェックボックスの後、作業マーカーをつけて・・・の作業がもうお手上げ状態です追記:ファイルを作成中、途中でキャンセルができるようにしたいですプ。いろいろ検索して、プログレスバーを調べていますが、ユーザーフォームを追加して作成する方法を調べています。 momoさんの手があくまで、もう少しいろいろ考えてみます。 ---- momoさまいろいろ試行錯誤してますが・・・まったく手がうごきません。。 ---- momoさん、お忙しい様ですね。。。要するに、何が出来れば良いのですか? ＞コピー作業をしないように、作業マーカー"■"をファイル名につけていましたが、この「コピー」は、新しい月のフォルダにブックをコピーですよね? ＞Listボックスで複数選択したものをセルのコピー&ペースト作業をしないようにできますか? この「コピー」は、新しい月のフォルダにコピーされたブックのセルの値をコピーですよね? フォルダにブックをコピーする部分はどこでその名前を変更する部分はどこでセルの値をコピーする部分はどこですか? ○○と言うマクロのなかの「〜〜〜」の辺りと言った感じで教えてもらえると良いと思います。 (HANA) ---- 返信がまだですが。。。コピーの件は、ファイルは全てコピーすれば良くて値の更新をするファイルと、しないファイルがあるんですね。＞個別のファイル名修正ができなくなりと言う事ですが、リストボックスで複数選択を可能にするとその手のイベントが発生しなく為る様です。個別に修正が必要なのでしょうか? 個別の修正が不要なら CopyProcの引数をもう一つ増やして Private Sub CopyProc(OpenPath As String, SavePath As String, flg As Boolean) If Not Dir(OpenPath) Like "*" & 作業マーカー & "*" Then を If flg Then に変更。呼び出す方（CommandButton3_Click）は CopyProc CopyPath & "¥" & .List(i, 0), PastPath & "¥" & .List(i, 1) を CopyProc CopyPath & "¥" & .List(i, 0), PastPath & "¥" & .List(i, 1), Not .Selected(i) に変更。で良いのかな。。。? ただ、私は値のコピーが必要なファイルと、不要なファイルは本当は見分ける方法が有るんじゃないかと思ってますが。。。? (HANA) ---- HANAさまご返信遅くなってすみません。 momoさんが忙しいと思い、しばらくこちらを見ておりませんでした。私もコードのことがあまりよくわからないので、あっているか核心はないのですが・・・フォルダにブックをコピーし、ブックの名前を翌月に変更するのは CommandButton3 のところですセルの値をコピーする部分は Private Sub CopyProc(OpenPath As String, SavePath As String) ワークシート名で、コピー作業をわけています。リンク更新のダイアログがでるのもここだと思います。 Private Sub CopyWork(myWs As Worksheet, Ptn As Integer) ワークシート名別に、どのセルをコピー、貼付け、クリアなどを書いてあります。＞コピーの件は、ファイルは全てコピーすれば良くて値の更新をするファイルと、しないファイルがあるんですね。はい、そうです。■がついてるものはセルの値コピー等はしません。ワークシートによっても、作業をしないものがあります。ですが、ブック自体のコピーは■関係なくすべてコピーします。＞個別に修正が必要なのでしょうか? はい、必要です。その理由は "○月xxxxxxx.xls"という題名なら、翌月に題名を変換してくれますが（1203）を（1204）とはしてくれないので、それを個別で変更します。＞ただ、私は値のコピーが必要なファイルと、不要なファイルは本当は見分ける方法が有るんじゃないかと思ってますが。。。? 私もなにか見分けられるものがあればと思っているんですがファイルもワークシートもたくさんあり、フォームもすべて同じではないのでなかなか共通して見分けられるもの見つかりません。それで■をつけたのですが上司に見た目が悪い、バッサリいわれたもので・・・ HANAさま、上記以外で足りないところがありましたら、ご指摘ください。どうぞよろしくお願いいたします。 ---- 作業をする人はどうやって見分けているのですか? ファイル名が暗号の様に成っていて、対応表と一つずつチェックしないとどのファイルが対象なのか分からないなんて事は無いと思いますが。それから（1203）が（1204）になれば個別修正は不要と言う事ですか? また、対象ファイルが事前に分かっているのに処理をするたびに毎回チェックをつけると言う仕様は馬鹿げていると思います。 (HANA) ---- ＞作業をする人はどうやって見分けているのですか? 私もmomoさんも馬鹿げていると思ったので、対象ファイルの題名に"■"をつけたのだと思います。それは、8個ほどのファイルの中に共通する条件がないためです。損益計算書や集計表なので、作業者は共通の何かを見分けて作業しておりません。 momoさんのコメントにもありますように、いまご多忙中で対応できないので、応急処置的なものをご提案頂いたと思うのですがファイルの仕分けは、もしかしたら他に方法があるのかもしれません… 私は素人ですので、なんとも申し上げられないのですが。ファイルが増減する可能性、セルの加工をするもの、しないものを自分で設定できるように、momoさんに自由度を高くしてもらっています。ここはイレジュラーなものが発生することを考えてそうしていただきました。＞それから（1203）が（1204）になれば個別修正は不要と言う事ですか? そのほかに（3月・4月）→（4月・5月）というものもあります。ほとんどは月の変更のための個別修正になっていますが年度の変わり目に、数字以外の部署名などの文字も変わる可能性もあります。 ---- でしたら、もう一つボタンを作って個別修正するモードと、コピーしないファイルを選ぶモードと切り換えて使う様にされるのはどうですか? (HANA) ---- HANAさまご連絡おそくなってすみません。全然思いつきませんでした! ボタンが増えるのは、まったく問題ないのでぜひご教授お願いします。 ---- ご教授って言われても、ボタンを一つ増やして貰って MultiSelect を切り換えるだけですが。。。ただ、そのままだとサイズが変わってしまう様なので元のサイズを取得して、切り上げ処理をしたサイズに変更する作業もつけておいた方が良いと思います。 '------ Private Sub CommandButton4_Click() With Me With .ListBox1 .Height = Application.RoundUp(.Height, -1) If .MultiSelect = fmMultiSelectMulti Then .ListStyle = fmListStylePlain .MultiSelect = fmMultiSelectSingle Else .ListStyle = fmListStyleOption .MultiSelect = fmMultiSelectMulti End If End With End With End Sub '------ イレギュラーな事が多い様なのでシートに展開した方が楽じゃないですか? 8つのファイルのコアに成るファイル名もシートに登録しておいて。。。まぁ、私がユーザーフォームが得意でないのも有ると思いますが。 (HANA) ---- HANAさまありがとうございます。私の知識がなく大変申し訳ございません。 CommandButton3の下に書いていただいたCommandButton4のコードを追加しました。リストにあるファイルをいくつか選択し、CommandButton4のボタンを押してみましたが何もおこりませんでした。 Private Sub ListBox1_AfterUpdate()と関係があるとは思うのですがどうしたらいいでしょうか? ---- ＞リストにあるファイルをいくつか選択し、CommandButton4のボタンを押してみましたが＞何もおこりませんでした。どう言った事を想定して居られるのか分かりませんがこれは仕様の共有が出来ていない様に思います。但し、それ以前に「何もおこらない」と言う事は無いと思いますので何かが違うのではないでしょうか。少なくとも、ListBox1 の左端の列に、チェックボックスが表示されたり・非表示に成ったりするとは思いますので。ちなみに、コマンドボタン4は＞個別修正するモードと、コピーしないファイルを選ぶモードと切り換えをするためのボタンです。まずチェックボックスが表示されてない状態で、個別修正をしてコマンドボタン4を押して、コピーしないファイルを選び実際のコピー作業を行う流れになります。 ※実際のコピー作業を行うコードとその呼出は別途変更が必要です。 (HANA) ---- すみません私が見落としておりました。＞少なくとも、ListBox1 の左端の列に、チェックボックスが表示されたり・非表示に成ったりするとは思いますので。 →これは確認できました。＞まずチェックボックスが表示されてない状態で、個別修正をして →フォルダを選択→リストボックスが出てる状態なので、コマンド4で非表示にしましたが、そのあとファイル名のどこを触っても個別修正ができません。私に知識がないので、確認作業も時間がかかりご説明も簡単ですとこのように理解できないこともあります。お手数おかけして申し訳ございません。 ---- でしたら、例を簡単にして動作を確認して下さい。例えば、ユーザーフォームにコマンドボタンを一つ、リストボックスを一つ作成。 UserForm_Initialize でテキトーに何かリストを作成 ListBox1_AfterUpdate が発動するかどうか確認のためメッセージボックスなど表示させる CommandButton1_Click はコマンドボタン4 用として載せたコードを貼り付けユーザーフォームを開くと、リストボックスはチェックボックスが無い状態でテキトーに作ったリストが表示されていると思います。どれか一つを選択した時、ListBox1_AfterUpdateで設定したメッセージボックスが表示される事を確認して下さい。また、複数選択出来ない（当然ですが）事も確認して下さい。その後、コマンドボタンを押します。リストボックスの列の先頭にチェックボックスが表示されて複数選択出来る様に成ります。その状態では、ListBox1_AfterUpdateで設定したメッセージボックスは表示されません。 (HANA) ---- ユーザーフォームにリストボックスとボタンなどをつくりましたがリストを適当にUserForm_Initializeでどのように作成したらいいかわかりません。個別修正ですが、切り替えボタンでファイル名を変えようとしたとき ListBox1_AfterUpdateではなく、個別修正できるのでしょうか? いまチェックボックスは消えてる状態なのですが、ファイル名をクリックしても何も動かない状態なので、どうなるのが正解がわからない状態です・・・ここだけのりきれば、ほとんど完成に近くなると思うのですがせっかく助けて頂いているのに、わからないことだらけで申し訳ございません ---- ＞リストを適当にUserForm_Initializeでどのように作成したらいいかわかりません。そこは、そんなに難しく考えずに。。。。 VBAのユーザーフォームの入門ページを探してみてリストボックスに関するページを見ると大抵はリストを設定する構文が載っていますので、それを使えば良いと思っただけですが。。。 http://www.google.co.jp/search?q=vba%E3%80%80%E3%83%A6%E3%83%BC%E3%82%B6%E3%83%BC%E3%83%95%E3%82%A9%E3%83%BC%E3%83%A0%E3%80%80%E3%83%AA%E3%82%B9%E3%83%88%E3%83%9C%E3%83%83%E3%82%AF%E3%82%B9&hl=ja&gbv=2&gs_nf=1&gs_l=hp.1.0.0i4j0j0i4l8.1360.10078.0.13281.22.18.4.0.0.1.500.3077.2-1j4j2j1.8.0.ytnsGGbc9VM&oq=vba%E3%80%80%E3%83%A6%E3%83%BC%E3%82%B6%E3%83%BC%E3%83%95%E3%82%A9%E3%83%BC%E3%83%A0%E3%80%80%E3%83%AA%E3%82%B9%E3%83%88%E3%83%9C%E3%83%83%E3%82%AF%E3%82%B9&aq=f&aqi=g1g-m1&aql= AddItem で追加しても良いでしょうしリストを作っておいて RowSource で取得しても良いと思います。＞何も動かない状態なので、どうなるのが正解がわからない状態です・・・その大きなコードは一旦保留にして、小さなサンプルを作って動きを確認する事をまず第一にやって下さい。＞切り替えボタンでファイル名を変えようとしたときここの認識はまだ違っている様に思えます。が、まずは動きを確認して貰った方が良いと思います。 (HANA) ---- HANAさまご連絡おそくなりました。教えて頂いたURLを参考にやってみたところやろうとしているところのイメージがよくわかりました（^^）ありがとうございました! Private Sub UserForm_Initialize() UserForm1.Caption = "商品名の入力" With ListBox1 .AddItem "りんご" .AddItem "みかん" .AddItem "バナナ" End With End Sub Private Sub ListBox1_AfterUpdate() Dim buf As Variant With Me.ListBox1 If .Tag = "" Then If MsgBox("個別修正しますか?", vbYesNo) = vbYes Then buf = Application.InputBox("ファイル名を修正してください。" & vbLf & vbLf & _ .List(.ListIndex, 0), , .List(.ListIndex, 1)) If VarType(buf) <> vbBoolean Then .List(.ListIndex, 1) = buf End If End If .Tag = "Rename" .ListIndex = -1 Else .Tag = "" End If End With End Sub Private Sub CommandButton1_Click() With Me With .ListBox1 .Height = Application.RoundUp(.Height, -1) If .MultiSelect = fmMultiSelectMulti Then .ListStyle = fmListStylePlain .MultiSelect = fmMultiSelectSingle Else .ListStyle = fmListStyleOption .MultiSelect = fmMultiSelectMulti End If End With End With End Sub 上記のように、ファイル名を変更しようと思ってクリックしたとき AfterUpdateのメッセージがでないのはなぜなのでしょうか・・・ ---- 左端にチェックボックスが無い状態でクリックしても ListBox1_AfterUpdateのメッセージボックスが表示されないのですか? それはおかしいと思いますが。。。新しいブックで試して貰っていますか? どの段階で、ListBox1_AfterUpdateが発動しなくなるか少しずつ確認してもらえますか? 1.ユーザーフォームにリストボックス一つ。 UserForm_Initialize と ListBox1_AfterUpdate のコードだけ入れて確認。 2.コマンドボタンを一つ追加して、確認。 3.CommandButton1_Click のコードを追加して確認。 4.コマンドボタンを押して、左側にチェックボックスが表示された状態で確認。 (HANA) ---- 前月と今月で同じリストボックスを使っているのが原因でしょうか? チェックボックスがない状態で、ファイルをクリックすると前月ファイルも今月ファイルも選択されるカンジです。切り替えはできるのですが、ファイルを選択した時点では何も起こらないのでコードが何かが足りないんでしょうか? いまの状態です↓ Option Explicit Private Const 初期フォルダ As String = "D:¥temp¥練習用¥10月" Private Const 作業マーカー As String = "■" Private Sub UserForm_Initialize() With Me With .ListBox1 .ColumnCount = 2 .ListStyle = fmListStyleOption .MultiSelect = fmMultiSelectMulti End With End With End Sub Private Sub CommandButton1_Click() Dim myFol As String Dim myPath As String Dim myMonth As String myFol = GetFolderPath If myFol Like "*月*" Then Me.TextBox1.Value = myFol myPath = GetMonth(myFol) Me.TextBox3.Value = myPath myMonth = AddMonth(myPath) Me.TextBox4.Value = myMonth Me.TextBox2.Value = Replace(myFol, myPath, myMonth) End If End Sub Private Sub CommandButton2_Click() Me.TextBox2.Value = GetFolderPath End Sub Private Sub CommandButton3_Click() Dim CopyPath As String Dim PastPath As String Dim CopyFile As String Dim PastFile As String Dim i As Long Dim ws As Worksheet CopyPath = Me.TextBox1.Value PastPath = Me.TextBox2.Value If CopyPath = "" Or PastPath = "" Then MsgBox "フォルダが指定されていません" Else 'フォルダチェック&作成 If Dir(PastPath, vbDirectory) = "" Then If MsgBox(PastPath & "フォルダがありません。" & vbCr & _ "フォルダを作成しますか?", vbYesNo) = vbYes Then MkDir PastPath Else MsgBox "キャンセルされました" Exit Sub End If End If 'ファイルコピー&リネーム With Me.ListBox1 For i = 0 To .ListCount - 1 CopyProc CopyPath & "¥" & .List(i, 0), PastPath & "¥" & .List(i, 1), Not.Selected(i) Next i End With MsgBox "作業完了" End If End Sub Private Sub CommandButton4_Click() With Me With .ListBox1 .Height = Application.RoundUp(.Height, -1) If .MultiSelect = fmMultiSelectMulti Then .ListStyle = fmListStylePlain .MultiSelect = fmMultiSelectSingle Else .ListStyle = fmListStyleOption .MultiSelect = fmMultiSelectMulti End If End With End With End Sub ---- ＞どの段階で、ListBox1_AfterUpdateが発動しなくなるか＞少しずつ確認してもらえますか? の結果を教えて下さい。「全て期待通りに成ったが、実際のコードに載せると期待通りに成らない」と言う事ですか? ＞いまの状態です載せて居られるコードには「ListBox1_AfterUpdate」が有りませんが? 実際も無いのか、こちらへコピー漏れなのか・・・・?? (HANA) ---- HANAさま＞どの段階で、ListBox1_AfterUpdateが発動しなくなるか変更したファイルがまず選択できません。以前は、ファイルを選択するとAfterUpdateのメッセージがでていました。ファイル名を修正すると、リストボックスの名前も変わっていました。まだすべて期待通りではなく、ファイルの部分がうまくいったらコピー作業を途中でキャンセルできるボタンなどをつけたいと思っています。 AfterUpdate掲載していませんでした。 CommandButton4_Click()の下からです↓ AfterUpdateの続きは上記やりとりの中で記載してある通りとなっています。 Private Sub TextBox1_Change() SetFileList End Sub Private Sub TextBox2_Change() SetFileList End Sub Private Sub TextBox3_Change() SetFileList End Sub Private Sub TextBox4_Change() SetFileList End Sub Private Sub ListBox1_AfterUpdate() Dim buf As Variant With Me.ListBox1 If .Tag = "" Then If MsgBox("個別修正しますか?", vbYesNo) = vbYes Then buf = Application.InputBox("ファイル名を修正してください。" & vbLf & vbLf & _ .List(.ListIndex, 0), , .List(.ListIndex, 1)) If VarType(buf) <> vbBoolean Then .List(.ListIndex, 1) = buf End If End If .Tag = "Rename" .ListIndex = -1 Else .Tag = "" End If End With End Sub ---- えっとですね。。。＞その大きなコードは一旦保留にして、小さなサンプルを作って＞動きを確認する事をまず第一にやって下さい。って書いてるんですけどね? その小さなサンプルで＞どの段階で、ListBox1_AfterUpdateが発動しなくなるか＞少しずつ確認してもらえますか? なんです。＞変更したファイルがまず選択できません。これは、既に出来ている大きなコードの話ですよね? こちらが知りたい事を、私が分かる様に教えてもらえないのであればこの辺りで失礼させて頂きます。 (HANA) ---- 申し訳ございません。教えていただいてる立場なので、決して意地悪で教えてないわけではないんですが・・・ AfterUpdateのコードがないとおっしゃってたので小さなサンプルのほうだと勘違いしておりました。小さなサンプルでは、AfterUpdateのファイルを選択すると、 "フォルダを作成しますか?" というメッセージのあと、ファイル変更のダイアログまででました。そこで名前を変更しても、リストボックスの中のファイル名は変わりませんでした。もう一度小さなサンプルのせます。よろしくおねがいします Private Sub UserForm_Initialize() UserForm1.Caption = "商品名の入力" With ListBox1 .AddItem "りんご" .AddItem "みかん" .AddItem "バナナ" End With End Sub Private Sub ListBox1_AfterUpdate() Dim buf As Variant With Me.ListBox1 If .Tag = "" Then If MsgBox("個別修正しますか?", vbYesNo) = vbYes Then buf = Application.InputBox("ファイル名を修正してください。" & vbLf & vbLf & _ .List(.ListIndex, 0), , .List(.ListIndex, 1)) If VarType(buf) <> vbBoolean Then .List(.ListIndex, 1) = buf End If End If .Tag = "Rename" .ListIndex = -1 Else .Tag = "" End If End With End Sub Private Sub CommandButton1_Click() With Me With .ListBox1 .Height = Application.RoundUp(.Height, -1) If .MultiSelect = fmMultiSelectMulti Then .ListStyle = fmListStylePlain .MultiSelect = fmMultiSelectSingle Else .ListStyle = fmListStyleOption .MultiSelect = fmMultiSelectMulti End If End With End With End Sub ---- 小さなサンプルで確認することはチェックボックスが表示されていない時 ListBox1_AfterUpdateに書いたコードが実行される事複数選択できない事チェックボックスが表示されている時 ListBox1_AfterUpdateに書いたコードが実行されない事代わりに複数選択出来る事です。＞リストボックスの中のファイル名は変わりませんでした。変わるかどうかは関係ないです。小さなサンプルのリストボックスの内容は、元のデータ状況とは違います。元のデータ状況に合わせたコードを動かして元のデータと同じ結果は得られるはずがありません。どうしても同じ様な動きをさせて確認したいならもう少し元のデータ状況に近付ける必要があると思いますよ。ただ、もともと小さなサンプルとして作って欲しかったコードは＞＞ ListBox1_AfterUpdate が＞＞発動するかどうか確認のためメッセージボックスなど表示させるですから Private Sub ListBox1_AfterUpdate() MsgBox "AfterUpdateが発動した" End Sub こういったものです。リストボックスの先頭にチェックボックスが無い状態で選択すると「AfterUpdateが発動した」とメッセージが表示されるので、 ListBox1_AfterUpdateに書いたコードが実行されていると分かります。次に、コマンドボタンをおして先頭にチェックボックスが有る状態で選択するとメッセージは表示されないので ListBox1_AfterUpdateに書いたコードが実行されていない事が分かります。これを確認してもらうために、小さなコードを作ってもらっています。 (HANA) ---- ありがとうございます! AfterUpdateのところ、作成しなおして動かしてみたところ切り替えがうまくできているのが確認できました。＞チェックボックスが表示されていない時 ListBox1_AfterUpdateに書いたコードが実行される事複数選択できない事 "AfterUpdateが発動した"とメッセージがでました。複数選択もできなかったです。＞チェックボックスが表示されている時 ListBox1_AfterUpdateに書いたコードが実行されない事代わりに複数選択出来る事複数選択もでき、確認できました。 Private Sub UserForm_Initialize() UserForm1.Caption = "商品名の入力" With ListBox1 .AddItem "りんご" .AddItem "みかん" .AddItem "バナナ" End With End Sub Private Sub ListBox1_AfterUpdate() MsgBox "AfterUpdateが発動した" End Sub Private Sub CommandButton1_Click() With Me With .ListBox1 .Height = Application.RoundUp(.Height, -1) If .MultiSelect = fmMultiSelectMulti Then .ListStyle = fmListStylePlain .MultiSelect = fmMultiSelectSingle Else .ListStyle = fmListStyleOption .MultiSelect = fmMultiSelectMulti End If End With End With End Sub よろしくおねがいします ---- 小さなサンプルで、動作の確認は出来ましたか。良かったです。後は元のプログラム（うまく動いていた状態のもの）に同じ仕組みを追加して下さい。コマンドボタン4の切り替えでファイル名の変更が可能になったり複数ファイルを選択出来る様になったらコマンドボタン3の関連の変更をして下さい。 (HANA) ---- HANAさん、ありがとうございます。うまく行ってた状態から、CommandButton4を挿入したら切り替えがうまくいきました! ファイルの変更もできましたし、複数の選択も問題ありませんでした。＞コマンドボタン3の関連の変更をして下さい。ここは、選択したファイルを[Private Const 作業マーカー As String = "■"]の "■"見立てる?という作業になるかと思うのですが、ここはどのようにすればいいでしょうか? Private Sub CopyProcこれとつながってくるというのはわかるのですが一人でコードを書くとなるとまったくです… 完成までご指導いただけないでしょうか? Private Sub CopyProc(OpenPath As String, SavePath As String) Dim ws As Worksheet With Application .ScreenUpdating = False .Calculation = xlCalculationManual .DisplayAlerts = False End With With Workbooks.Open(OpenPath) '値コピー作業 If Not Dir(OpenPath) Like "*" & 作業マーカー & "*" Then If .Worksheets.Count = 1 Then CopyWork .Worksheets(1), 3 Else For Each ws In .Worksheets If ws.Name = "差額" Then CopyWork ws, 1 ElseIf ws.Name = "システム" Then CopyWork ws, 2 ElseIf ws.Name <> "会社差額" And ws.Range("B7").Value = "売上高" Then CopyWork ws, 3 End If Next ws End If End If 'リンク更新作業 For Each ws In .Worksheets ws.Cells.Replace Me.TextBox3.Value, Me.TextBox4.Value, xlPart, xlByRows Next ws .SaveAs SavePath .Close False End With With Application .DisplayAlerts = True .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With End Sub ---- この話が始まった最初頃に書いてますが＞CopyProcの引数をもう一つ増やして＞ Private Sub CopyProc(OpenPath As String, SavePath As String, flg As Boolean) ＞＞ If Not Dir(OpenPath) Like "*" & 作業マーカー & "*" Then ＞を＞ If flg Then ＞に変更。＞＞呼び出す方（CommandButton3_Click）は＞ CopyProc CopyPath & "¥" & .List(i, 0), PastPath & "¥" & .List(i, 1) ＞を＞ CopyProc CopyPath & "¥" & .List(i, 0), PastPath & "¥" & .List(i, 1), Not .Selected(i) ＞に変更。＞＞で良いのかな。。。? をやってみて下さい。 (HANA) ---- リストボックスのファイルをいくつか選択してからコマンドボタン3を押してみました。コンパイルエラーというのがCopyProcの部分ででていました。 CopyProc CopyPath & "¥" & .List(i, 0), PastPath & "¥" & .List(i, 1), Not .Selected(i) 「引数の数が一致していません。または不正なプロパティを指定しています」と書いてありました。同じく、切り替えてファイル名を変更してやってみても同様のメッセージがでました。今の状態をのせました↓ どこが悪いのかまったくわかりません。。おねがいします Option Explicit Private Const 初期フォルダ As String = "D:¥temp¥練習用¥10月" Private Const 作業マーカー As String = "■" Private Sub UserForm_Initialize() With Me With .ListBox1 .ColumnCount = 2 End With End With End Sub Private Sub CommandButton1_Click() Dim myFol As String Dim myPath As String Dim myMonth As String myFol = GetFolderPath If myFol Like "*月*" Then Me.TextBox1.Value = myFol myPath = GetMonth(myFol) Me.TextBox3.Value = myPath myMonth = AddMonth(myPath) Me.TextBox4.Value = myMonth Me.TextBox2.Value = Replace(myFol, myPath, myMonth) End If End Sub Private Sub CommandButton2_Click() Me.TextBox2.Value = GetFolderPath End Sub Private Sub CommandButton3_Click() Dim CopyPath As String Dim PastPath As String Dim CopyFile As String Dim PastFile As String Dim i As Long Dim ws As Worksheet CopyPath = Me.TextBox1.Value PastPath = Me.TextBox2.Value If CopyPath = "" Or PastPath = "" Then MsgBox "フォルダが指定されていません" Else 'フォルダチェック&作成 If Dir(PastPath, vbDirectory) = "" Then If MsgBox(PastPath & "フォルダがありません。" & vbCr & _ "フォルダを作成しますか?", vbYesNo) = vbYes Then MkDir PastPath Else MsgBox "キャンセルされました" Exit Sub End If End If 'ファイルコピー&リネーム With Me.ListBox1 For i = 0 To .ListCount - 1 'CopyProc CopyPath & "¥" & .List(i, 0), PastPath & "¥" & .List(i, 1) CopyProc CopyPath & "¥" & .List(i, 0), PastPath & "¥" & .List(i, 1), Not .Selected(i) Next i End With MsgBox "作業完了" End If End Sub Private Sub CommandButton4_Click() With Me With .ListBox1 .Height = Application.RoundUp(.Height, -1) If .MultiSelect = fmMultiSelectMulti Then .ListStyle = fmListStylePlain .MultiSelect = fmMultiSelectSingle Else .ListStyle = fmListStyleOption .MultiSelect = fmMultiSelectMulti End If End With End With End Sub Private Sub ListBox1_AfterUpdate() Dim buf As Variant With Me.ListBox1 If .Tag = "" Then If MsgBox("個別修正しますか?", vbYesNo) = vbYes Then buf = Application.InputBox("ファイル名を修正してください。" & vbLf & vbLf & _ .List(.ListIndex, 0), , .List(.ListIndex, 1)) If VarType(buf) <> vbBoolean Then .List(.ListIndex, 1) = buf End If End If .Tag = "Rename" .ListIndex = -1 Else .Tag = "" End If End With End Sub Private Sub TextBox1_Change() SetFileList End Sub Private Sub TextBox2_Change() SetFileList End Sub Private Sub TextBox3_Change() SetFileList End Sub Private Sub TextBox4_Change() SetFileList End Sub Private Sub SetFileList() Dim myFile As String Dim myC As New Collection Me.ListBox1.Clear With Me.TextBox1 If .Value <> "" Then myFile = Dir(.Value & "¥*.xls*") Do Until myFile = "" With Me.ListBox1 .AddItem .List(.ListCount - 1, 0) = myFile .List(.ListCount - 1, 1) = Replace(myFile, Me.TextBox3.Value, Me.TextBox4.Value) End With myFile = Dir() Loop End If End With End Sub Private Function GetFolderPath() As String With Application.FileDialog(msoFileDialogFolderPicker) .InitialFileName = 初期フォルダ If .Show = True Then GetFolderPath = .SelectedItems(1) End If End With End Function Private Sub CopyProc(OpenPath As String, SavePath As String) Dim ws As Worksheet With Application .ScreenUpdating = False .Calculation = xlCalculationManual .DisplayAlerts = False End With With Workbooks.Open(OpenPath) '値コピー作業 If Not Dir(OpenPath) Like "*" & 作業マーカー & "*" Then If .Worksheets.Count = 1 Then CopyWork .Worksheets(1), 3 Else For Each ws In .Worksheets If ws.Name = "差額" Then CopyWork ws, 1 ElseIf ws.Name = "システム" Then CopyWork ws, 2 ElseIf ws.Name <> "会社差額" And ws.Range("B7").Value = "売上高" Then CopyWork ws, 3 End If Next ws End If End If 'リンク更新作業 For Each ws In .Worksheets ws.Cells.Replace Me.TextBox3.Value, Me.TextBox4.Value, xlPart, xlByRows Next ws .SaveAs SavePath .Close False End With With Application .DisplayAlerts = True .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With End Sub Private Sub CopyWork(myWs As Worksheet, Ptn As Integer) Dim myArea As Range Dim myCol As Variant Dim myRng As Range Dim strRowRng As String Dim aryCpyRng As Variant Dim aryDelRng As Variant Dim buf As Variant Select Case Ptn Case 1 strRowRng = "7:8,11:13,17:29,38:39,43:43,51:53,55:60,65:73" aryCpyRng = Array("R→E", "AC→Q") aryDelRng = Array("F", "R", "AC") Case 2 strRowRng = "4:27,34:57,64:88,95:119,155:170,179:190,198:208,217:224,233:240,249:262,270:273" aryCpyRng = Array("K→D", "Q→J") aryDelRng = Array("E", "K", "P", "Q") Case 3 strRowRng = "7:8,11:13,17:29,38:39,51:53,55:60,65:73" aryCpyRng = Array("V→J", "AG→U") aryDelRng = Array("K", "V", "AF", "AG") End Select With myWs For Each myArea In .Range(strRowRng).Areas For Each myCol In aryCpyRng buf = Split(myCol, "→") With myArea .Columns(buf(1)).Value = .Columns(buf(0)).Value End With Next myCol Next myArea For Each myArea In .Range(strRowRng).Areas For Each myCol In aryDelRng For Each myRng In myArea.Columns(myCol).Cells If myRng.HasFormula = False Then myRng.ClearContents End If Next myRng Next myCol Next myArea End With End Sub ---- 1. ＞CopyProcの引数をもう一つ増やして＞ Private Sub CopyProc(OpenPath As String, SavePath As String, flg As Boolean) 2. ＞ If Not Dir(OpenPath) Like "*" & 作業マーカー & "*" Then ＞を＞ If flg Then ＞に変更。 3・＞呼び出す方（CommandButton3_Click）は＞ CopyProc CopyPath & "¥" & .List(i, 0), PastPath & "¥" & .List(i, 1) ＞を＞ CopyProc CopyPath & "¥" & .List(i, 0), PastPath & "¥" & .List(i, 1), Not .Selected(i) ＞に変更。三つ変更ですよ? この行 Private Sub CopyProc(OpenPath As String, SavePath As String) と、この行 If Not Dir(OpenPath) Like "*" & 作業マーカー & "*" Then も変えてもらうよう書いていますが? (HANA) ---- ありがとうございました。私が見落としておりました。やってみたところ、うまく新しくフォルダ作成できました! 内容を検証してまたご報告させていただきます。ここまで本当にいろいろ教えていただき感謝しかありません。 ---- HANAさん、早速すみません。。 ElseIf ws.Name <> "会社差額" And ws.Range("B7").Value = "売上高" Then ここの部分をワークシートの"会社差額"と"あいう"を含むものを除外にしたいのですが ElseIf ws.Name <> "会社差額" And "*" & あいう & "*" Then でやってみたところ、思ったとおりうまくできませんでした。 "あいう"の文字列を含むというのはどのようにしたらいいのでしょうか? ------------------------------------ Private Sub CopyProc(OpenPath As String, SavePath As String, flg As Boolean) Dim ws As Worksheet With Application .ScreenUpdating = False .Calculation = xlCalculationManual .DisplayAlerts = False End With With Workbooks.Open(OpenPath) '値コピー作業 If flg Then If .Worksheets.Count = 1 Then CopyWork .Worksheets(1), 3 Else For Each ws In .Worksheets If ws.Name = "差額" Then CopyWork ws, 1 ElseIf ws.Name = "システム" Then CopyWork ws, 2 ElseIf ws.Name <> "会社差額" And ws.Range("B7").Value = "売上高" Then CopyWork ws, 3 End If Next ws End If End If 'リンク更新作業 For Each ws In .Worksheets ws.Cells.Replace Me.TextBox3.Value, Me.TextBox4.Value, xlPart, xlByRows Next ws .SaveAs SavePath .Close False End With With Application .DisplayAlerts = True .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With End Sub ---- 再度すみません。リストボックスでチェックしてないファイルが必ず5個でなければいけないのですがコマンド3のボタンを押したとき、チェックしてないファイルが5個以下、以上のとき "ファイルが5個ではありません"と警告のメッセージを出すことは可能でしょうか? よろしくお願いいたします。 ---- ＞ElseIf ws.Name <> "会社差額" And "*" & あいう & "*" Then ＞でやってみたところ、思ったとおりうまくできませんでした。＞"あいう"の文字列を含むというのはどのようにしたらいいのでしょうか? この記述は、確かに構文として正しくないです。ご自身の分かるところまで簡素化して確認コードを作成し確認してください。前回の流れもその様にしましたね。状況を簡素化してどの様に書くか考える。それをコード化して、上手く動く事を確認する。最後に、実際のコードに同じ仕組みを組み込む。いつだってこれの繰り返しだと思います。実際は、ループ処理の中で「ws.Name」を確認しますがぐっと簡単にして、文字を固定化して考えれば良いと思います。ちなみに「Dir(OpenPath)」が、作業マーカーを含まないの確認は If Not Dir(OpenPath) Like "*" & 作業マーカー & "*" Then でしたよね? 上の方で Private Const 作業マーカー As String = "■" としてありますので、これは If Not Dir(OpenPath) Like "*■*" Then と書いてあることになります。この辺りも曖昧に成っている様に思います。＞"ファイルが5個ではありません"と警告のメッセージを出すことは可能でしょうか? 可能だと思いますが、現在の仕様は「自由度」を追求していると思っていますのでそこから外れる事に成ってしまう様に感じます。それなら、シート上にキーワードを設けておいて簡単に変更出来る様にしておいた方が良いと思います。 (HANA) ---- HANAさん、ありがとうございます。アドバイスを頂いて、いろいろ考えてみたんですがこれが精一杯で・・・ ElseIf ws.Name <> "会社差額" And ws.Name <> "あいう*" Then これでエラーもでずに、一応”作業完了”までいきました。＞"ファイルが5個ではありません"と警告のメッセージを出すことは可能でしょうか? この件ですが、”チェックしてないファイルは○個です”というものならいかがでしょうか? 間違えないように確認だけですので、ユーザーフォームのテキストでチェックしてない数がでるだけでもかまいません。本やネットでも調べたのですが、見つけることできず悩んでおります。ご提案いただいたシートにキーワードは、上司に反対されてしまいました（＞＜）。申し訳ございません。 ---- こんなのを試してみます。 Sub TEST含まない() Dim Moji As String Moji = "会社差額" '←ここを色々変えてみる If Moji <> "会社差額" And Moji <> "あいう*" Then MsgBox "処理対象" End If End Sub 変数:Moji に入れた単語が・「会社差額」・「あいう」で始まらない時『処理対象』のメッセージボックスが出れば良いです。今は「会社差額」を入れてあって Moji <> "会社差額" が成立するのでメッセージボックスは出ません。もう一つの Moji <> "あいう*" で想定するシート名を変数:Moji に入れて期待通りの結果に成るか確認して下さい。期待通りの結果に成らないと思いますので、その場合は単独で If Moji <> "あいう*" Then の部分を検討し、の期待通りの結果を得られる様に変更して下さい。完成したら、次は「Moji <> "会社差額" And」と組み合わせて下さい。最後に、実際のコードの該当部分を変更して下さい。処理対象外のファイルの見分け方に関してですが現在、処理対象外の【シート】の名前は直接コード内に書いてますよね? 処理対象外のファイルの名前を直接コード内に書くのと、何かがそんなに違いますか? 勿論、そう言った事はしない方が良いとは思いますが。＞シートにキーワードは、上司に反対されてしまいました（＞＜）。シートを増やすのが駄目だと言う事なら、全く別のブックにする方法も有ると思います。何を何処までするかってのはいつでも問題になると思いますが。 (HANA) ---- HANAさん、早速ありがとうございました。ということは、私のは間違っているのですね・・・ご提案いただいたコード、私にも理解できるのですが、 "会社差額"では成功しましたが、"あいう*"のほうはコード自体書いたことないのでどうしたらいいのか… 考えられることはすべてやりましたが MsgBoxがでないので間違ってるというのはわかるので、私なりに何時間も調べていますが、見つけられないと途方にくれてしまい正直つらいです Sub TEST含まない() Dim Moji As String Moji = "あいう" & "*" '←ここを色々変えてみる" If Moji <> "あいう" & "*" Then MsgBox "処理対象" End If End Sub ＞現在、処理対象外の【シート】の名前は直接コード内に書いてますよね? 処理対象外のファイルの名前を直接コード内に書くのと、何かがそんなに違いますか? 処理対象外、処理対象も両方シート名を4つにわけて記載しています。 CopyWork ws, 1と2はワークシートの編集の処理をしていて CopyWork ws, 3は、1〜3にあてはまらないすべてのシート名が編集処理の対象になるので、その数が20シートぐらいあります。ファイルによってもシート名もシートの数も違います。その月によって対象外のファイルが増えたりすることもあるので、おっしゃるとおり、コードのために固定できないと思います。あと実際使ってみるといろいろ問題がでてきておりまして私が上記できるようになったらでかまいませんので、見て頂けますでしょうか? @ファイルをコピーしてる段階だと思うのですが、ワークシートの中の前月にあたる部分が今月に置き換わるのをやめたい。コマンドボタン3でしょうか・・・だいぶ上の方なのですが、momoさんとお話していたところを書きます。＞いえ、それだけなら Sub test() Dim r As Range For Each r In Range("B5:E5") r.Value = r.Value Mod 12 + 1 Next r End Sub このあと続きがないのですが、実際は表のセル部分、先月（5月）→今月（6月）に変わっています。 A編集したコピー後のファイルですが、数式が入っている部分をdeleteせずに残したいとお願いしたのですが、すべてデリートに変更したいですたぶん、このあたりだと思うところは、コメントアウトして試してみたのですがまったく変わりませんでした。aryDelRngがデリートを意味してるのはなんとなくわかるのですが数式はつぶさないというのがどこになるのか・・・まったく私が検討違いなところを見ていたらすみません。 Private Sub CopyProc(OpenPath As String, SavePath As String) Dim ws As Worksheet With Application .ScreenUpdating = False .Calculation = xlCalculationManual .DisplayAlerts = False End With With Workbooks.Open(OpenPath) '値コピー作業 If Not Dir(OpenPath) Like "*" & 作業マーカー & "*" Then If .Worksheets.Count = 1 Then CopyWork .Worksheets(1), 3 Else For Each ws In .Worksheets If ws.Name = "差額" Then CopyWork ws, 1 ElseIf ws.Name = "システム" Then CopyWork ws, 2 ElseIf ws.Name <> "会社差額" And ws.Range("B7").Value = "売上高" Then CopyWork ws, 3 End If Next ws End If End If 'リンク更新作業 For Each ws In .Worksheets ws.Cells.Replace Me.TextBox3.Value, Me.TextBox4.Value, xlPart, xlByRows Next ws .SaveAs SavePath .Close False End With With Application .DisplayAlerts = True .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With End Sub Private Sub CopyWork(myWs As Worksheet, Ptn As Integer) Dim myArea As Range Dim myCol As Variant Dim myRng As Range Dim strRowRng As String Dim aryCpyRng As Variant Dim aryDelRng As Variant Dim buf As Variant Select Case Ptn Case 1 strRowRng = "7:8,11:13,17:29,38:39,43:43,51:53,55:60,65:73" aryCpyRng = Array("R→E", "AC→Q") aryDelRng = Array("F", "R", "AC") Case 2 strRowRng = "4:27,34:57,64:88,95:119,155:170,179:190,198:208,217:224,233:240,249:262,270:273" aryCpyRng = Array("K→D", "Q→J") aryDelRng = Array("E", "K", "P", "Q") Case 3 strRowRng = "7:8,11:13,17:29,38:39,51:53,55:60,65:73" aryCpyRng = Array("V→J", "AG→U") aryDelRng = Array("K", "V", "AF", "AG") End Select With myWs For Each myArea In .Range(strRowRng).Areas For Each myCol In aryCpyRng buf = Split(myCol, "→") With myArea .Columns(buf(1)).Value = .Columns(buf(0)).Value End With Next myCol Next myArea For Each myArea In .Range(strRowRng).Areas For Each myCol In aryDelRng For Each myRng In myArea.Columns(myCol).Cells If myRng.HasFormula = False Then myRng.ClearContents End If Next myRng Next myCol Next myArea End With End Sub If flg Then If .Worksheets.Count = 1 Then CopyWork .Worksheets(1), 3 Else For Each ws In .Worksheets If ws.Name = "差額" Then CopyWork ws, 1 ElseIf ws.Name = "システム" Then CopyWork ws, 2 ElseIf ws.Name <> "会社差額" And ws.Range("B7").Value = "売上高" Then CopyWork ws, 3 End If Next ws End If ---- ＞コード自体書いたことないのでどうしたらいいのか… しかし、似たような部分は momoさんが書いて下さっているコード内に有りますし【ここですよ】ってのは、私は既に抜粋してお知らせして居るつもりです。この話が始まった所以降を、もう一度読み直してみて下さい。そして、一気に完成に近づけるのではなく段階を追って作っていって下さい。 (HANA) ---- 今改めて、もっと複雑なのかなと思ってやりなおしてみましたがシート名を"あいうえお"としたとき、メッセージはでないのですがリンゴといれても何もでませんでした。何が間違っているのかわかりません。 Sub TEST含まない() Dim Moji As String Moji = "あいう" If Not Dir(Moji) Like "あいう" & "*" Then MsgBox "処理対象" End If End Sub ---- ＞もっと複雑なのかなと思ってやりなおしてみましたがもっと単純ですよ?これはテストコードのしかも第一段階ですから。シートのループ処理では ws.Name でシート名を確認して居ますね。ですから If ws.Name <> "会社差額" Then と言う書き方に成りますが、今回は Moji の内容と確認するので If Moji <> "会社差額" Then とかいて、 If Moji.Name <> "会社差額" Then とはやらないですよね。当初載せて居られるコードも、前半部分はこの様になっています。参考にした構文の内 If〜Then は改めなくても分かると思いますが If Not Dir(OpenPath) Like "*■*" Then ‾‾‾ ‾‾‾‾--------‾ ‾‾‾‾ その他の部分がそれぞれどういう理由で書かれているのか確認して下さい。字面から分からない部分は、こまめにヘルプで確認してみて下さい。該当の文字内にカーソルが有る状態で [F1] キーを押すとその項目に関するヘルプが立ち上がります。 (HANA) ---- 私にとってはこれを説くのも大変難しいことですし、コードを書いたこともないのですから、たかがこんな短いものもやるもの必死です。このように直してみましたが、今度はどんなシート名でも "処理対象"となってしまいます。 Sub TEST含まない() Dim Moji As String Moji = "あいう" If Not Dir(Moji) Like "あいう*" Then MsgBox "処理対象" End If End Sub ---- 今までの流れを見ていないので、最後の部分に対するコメントですが、文字を含む含まないの判断をするサンプルです。 (なぜ Dir を使うのかがわかっていないので無視しました) Sub Test2() For Each Moji In Array("あいうえお", "かきくあいうけこ", "たちつてと", "えおあいう") If Moji Like "あいう*" Then MsgBox "チェック1.[" & Moji & "] は「あいう」で始まっています。" End If If Moji Like "*あいう" Then MsgBox "チェック2.[" & Moji & "] は「あいう」で終わっています。" End If If Moji Like "*あいう*" Then MsgBox "チェック3.[" & Moji & "] は「あいう」を含んでいます。" End If If Not Moji Like "*あいう*" Then MsgBox "チェック4.[" & Moji & "] は「あいう」を含んでいません。" End If Next End Sub ご参考までに。 (Mook) ---- Mookさん、ありがとうございます。わかりやすかったのですが、自分でやるとシート名を何にかえてもメッセージがでません。。。 Sub TEST含まない() For Each Moji In Array("あいう") If Not Moji Like "あいう*" Then MsgBox "処理対象" End If Next End Sub ---- それは条件の書き方が悪いんではなくて、データの指定の仕方の問題ではないでしょうか。上のコードのどこにもシート名は出てきていませんけれど・・・。内容理解していませんが、試したいのはこういうことでしょうか。 Sub あいうで始まらないシート名を表示() For Each ws In WorkSheets If Not ws.Name Like "あいう*" Then MsgBox ws.Name & "は処理対象" End If Next End Sub 闇雲にやるよりは、細部の機能を理解しながら進めたほうが結局は早道だと思います。全体がわかっていないのでこれ以上の横槍は差し控えますね。中途半端に邪魔してしまってすみません。 (Mook) ---- Mookさん HANAさんありがとうございました! "あいう"で始まらないシートと"会社差額"というシートを処理対象の除外にしたかったのですが Mookさんの教えて頂いたとおり、やってみましたらできました! 私がまったく理解できてなかったのもこれでよくわかりました。ヘルプは難しくて理解できなかたのですが、Arrayは文字列で使用するということもわかりましたしすべて理解できたわけではありませんが、"あいう"から始まるワークシートと、 "会社差額"のワークシートがあったときメッセージがでなくなりました。ちょっと疑問なんですが、Likeを使うと<>は使用できないのでしょうか? Sub あいうで始まらないシート名を表示() For Each ws In Worksheets If Not ws.Name Like "あいう*" And ws.Name <> "会社差額" Then MsgBox ws.Name & "は処理対象" End If Next End Sub ---- 横やりしないと言いながらなんですが、二つだけ。ちょっと今の段階で Array を使ってしまったのは誤解を招いてしまって失敗だったかもしれませんが、Array は文字列も使えますけれど、他のデータ型でも使用できます。 >ちょっと疑問なんですが、Likeを使うと<>は使用できないのでしょうか? どちらも使えますし、上のコードでアクティブなブックの「あいう」で始まっていなくて、会社差額でないシート名がすべて表示されますが、メッセージが出ないのは別原因ではないでしょうか。 (Mook) ---- Mookさん、ありがとうございます。 If Not ws.Name <> Like <> "あいう*" And ws.Name <> "会社差額" Then ↓ ↓ どちらにいれても、コンパイルエラーになります。どのようにLike と <>は組み合わせればいいのでしょうか? 何か数式のように決まりがあるのでしょうか? ---- 一度VBAの「演算子」（特に比較演算子）をヘルプを読むなり、ネットで調べてみてはどうでしょうか。一例ですが。 http://www.geocities.jp/cbc_vbnet/kisuhen/enzanshi.html http://www.officepro.jp/excelvba/basic/index6.html 算数の計算で 5+×3 という式がおかしいように、Like と <> はどちらも比較を行うものなので同列に書いては式が成り立ちません。先にも書きましたけれど、上の質問者さんが提示されたサンプルで、ではない(Not)、「あいう」ではじまる( ws.Name Like "あいう*" ) つまり「あいう」ではじまらない( Not ws.Name Like "あいう*" ) 且つ(And) 会社差額ではない（ ws.Name <> "会社差額"）は出来ていますけれど、やりたいことは違うのでしょうか。マクロにする前に、やりたいことをまず言葉で整理してはどうでしょうか。読み返してみて、 >"あいう"で始まらないシートと"会社差額"というシートを処理対象の除外にしたかったのですがというのは単純に、「あいう」で始まるシートという事ですか?であれば If ws.Name Like"あいう*" Then ですけれど。まずは考えを整理することを習慣付けてはと思います。 HANA さん、途中で邪魔してしまってすみません。 (Mook) ---- To Mookさん以下の様なやりとりがされていますがミニーさん＞＞ちょっと疑問なんですが、Likeを使うと<>は使用できないのでしょうか? Mookさん＞どちらも使えます・・・★ ミニーさん＞＞どのようにLike と <>は組み合わせればいいのでしょうか? Mookさん＞ Like と <> はどちらも比較を行うものなので同列に書いては式が成り立ちません。 ★の部分は、どういう意図だったのですか? そうそう＞＞"あいう"で始まらないシートと"会社差額"というシートを処理対象の除外これは書き間違いだと思います。当初の質問は↓ですので。＞＞ワークシートの"会社差額"と"あいう"を含むものを除外にしたい (HANA) ---- ＞＞ちょっと疑問なんですが、Likeを使うと<>は使用できないのでしょうか? ＞どちらも使えます・・・★ あぁ、そこが誤解を招いたのでしょうか。私が一緒と思ったのは If ( ○○ <> ××) Or (△△ Like □□) Then のような組み合わせを「一緒に」だったのですが、やりたかったのは △△ Like □□ を Not △△ Like □□ のようにしたかったということのようですね。まさか単一の条件式の中に使うとは思いませんでした。無理やり書けば (( △△ Like □□ ) <> True ) ともかけますが、これは混乱させるだけですね^^;;。これは蛇足もいいところでした。＞＞"あいう"で始まらないシートと"会社差額"というシートを処理対象の除外にしたかったは後から思いましたが、（"あいう"で始まらないシートと"会社差額"というシート）を処理対象の除外にしたかったではなく（"あいう"で始まらないシート）と（"会社差額"というシートを処理対象の除外にしたかった）ということだったでしょうか。＞＞ワークシートの"会社差額"と"あいう"を含むものを除外にしたいであれば、上の Sub あいうで始まらないシート名を表示() For Each ws In Worksheets If Not ws.Name Like "あいう*" And ws.Name <> "会社差額" Then MsgBox ws.Name & "は処理対象" End If Next End Sub だと思うのですが、 >"あいう"から始まるワークシートと、 "会社差額"のワークシートがあったときメッセージがでなくなりました。の現象が理解できませんでした。 (Mook) ---- To Mookさん＞私が一緒と思ったのは〜〜でしたか。ミニーさんがこの部分、読んで下さると良いですが。＞〜〜の現象が理解できませんでした。「があったとき」→「だったとき」の書き間違いじゃないですか? よって、この件はクリア出来たのではないかと思っていますが。まだ、実際のコードに上手く組み込めるかは分からないですが。 (HANA) ---- あっ > "会社差額"のワークシートがあったときメッセージがでなくなりました。は問題提起ではなく、解決の報告だったのでしょうか? だとしたら、大きな勘違いをしていました。で、その後の部分は別の興味からの質問だったのですね。 (Mook) ---- HANAさん、Mookさん私のせいで申し訳ございません（T_T) いまこちらみてびっくりしました・・・お二人のおかげで、サンプル ...; http://www.excel.studio-kazu.jp/wiki/kazuwiki/201110/20111027111622.txt - [detail] - similar

PREV NEXT

訪問者：カウンタ