[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『1.VBAでファイル名の一部を一括変換』（ミニー）
はじめまして
このたびVBAで下記のような作業をしようと思っています。
先月のフォルダとその中のエクセルをコピーして、
今月のフォルダを作成しようと思っています。
◆作成したもの
【ユーザーフォーム】
作成したい月：（ ）→当月を入力するテキストを作りました。
フォルダとファイルコピーをするコマンド実行ボタンがあります。
◆やりたいこと
\x{fffd}@"9月"というフォルダから"10月"フォルダを作成
\x{fffd}A作成した１０月フォルダの中にあるエクセルファイルの名前が
"９月"という部分を１０
月に変更。
ファイル名はすべて"9月xxxxxxxxx.xls"という名前です。
\x{fffd}Bコピーと名前の変更ができたらそのフォルダを表示
ただ、フォルダを作成して、ファイルをコピーまでは
この掲示板にも掲載されていたので、なんとかなりそうな気がするのですが、
まとめてファイルの名前を変えるというところがわかりません。
ご教授頂きたくお願いいたします。
わからないのがファイル名の変更部分だけでしたら Dir関数でループさせて、Nameステートメントでリネームしてあげれば出来そうですね。
サンプルを載せますので、これで引数を渡すようにしたり ユーザーフォームから呼び出せる形にすれば出来るはずです。
Sub test() Dim myPath As String Dim BeforeText As String Dim AfterText As String
myPath = "D:\test\" BeforeText = "９月" AfterText = "１０月"
myFile = Dir(myPath & BeforeText & "*.xls")
Do Until myFile = ""
Name myPath & myFile As myPath & Replace(myFile, BeforeText, AfterText)
myFile = Dir()
Loop
End Sub
（ｍｏｍｏ）
いとも簡単にありがとうございます。
まだ他の部分ができてないので、試してないのですが
後ほどやってみます。
ですが、初心者で全部できる自信がありません。。
できれば、最初から教えていただけると助かるのですが・・・
書き忘れてしまいましたが、Excel2003です
よろしくおねがいいたします（ｖｖ）
私が最初から書いてしまうのは簡単ですが、後々のメンテナンスに困りませんか？ せっかく >この掲示板にも掲載されていたので、なんとかなりそうな気がするのですが という所まで調べておられるようですし、何とかなる部分まで頑張ってみませんか？
わからない部分のサポートはしますから、ご自身で少しでも頑張ってみましょう。 その方が後が楽ですし、上達も早いですよ。 （ｍｏｍｏ）
ひとつ教えていただきたいのですが、
ユーザーフォームのテキストから
月が変わっても対応できるように、
下記コードも変えたいのですが、どのようにすればいいでしょうか？
ユーザーフォームのテキストの方法も
そもそもいい方法なのかもわかりません。。
BeforeText = "９月"
AfterText = "１０月"
よろしくおねがいします。
>ユーザーフォームのテキストから月が変わっても対応できるように 上のコードの中身をフォームのコードにして、
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を"９月" TextBox2を"１０月"とすれば 同じように動きます。
わかりやすく実験するなら Sub test2() test3 "テストです" End Sub
Sub test3(a As String) MsgBox a End Sub こんなのでtest2を実行してみるとか （ｍｏｍｏ）
作成月（10月）しかテキスト作ってない場合は、
"TextBox2 - 1"
というカンジで、９月を認識させることもできるのでしょうか？
え～と、そのままでは当然エラーですが 単純に－１だと１月の時に１２月にならないので、こんなのを試してみてください 日付型で前月を出しています。
Sub test4() Dim a As String Dim IntMonth As Integer Dim StrMonth As String
a = "１０月"
IntMonth = Month(DateSerial(Year(Date), Val(StrConv(a, vbNarrow)), 0))
MsgBox IntMonth
StrMonth = StrConv(IntMonth, vbWide) & "月"
MsgBox StrMonth End Sub
（ｍｏｍｏ）
そうですよね。
月や年が変わった場合のこと考えてませんでした。。
今思ったのですが、
コピー先、コピー元のフォルダの場所も
ユーザーフォームで指定するようにした方がいいでしょうか？
>コピー先、コピー元のフォルダの場所もユーザーフォームで指定するようにした方がいいでしょうか？
場所が変わったり、不確定な場所だったりするのでしたらその方が良いですね。 （ｍｏｍｏ）
ちなみにフォルダ名はどのようになっていますか？
D:\････\９月 のような感じで、その中に９月から始まるファイルがありますか？
９月から始まらないファイルやxls以外のファイルはありますか？
年が変わった場合は？
と、色々考えないといけませんね。 （ｍｏｍｏ）
ちょっと所用があって今日はもう見られないかもしれないので・・・ 参考に書いたコードで遊びながら試してみてください。 わからない所はまた後日対応させて頂きます。
事前準備として、新規のブックを開きます。 ユーザーフォームを挿入して Labelを４個 TextBoxを４個 CommandButtonを３個 配置してください。 場所や大きさ、文字などはコード内で成形するので気にしなくて結構です。
で、フォームのコード欄に以下を貼り付け
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
これで、実行してみてください。 年の変わり目は対応していません。 あくまでサンプルです。 （ｍｏｍｏ）
当たり前だと思っていました！
こうやって作ることが出来るんですね！！
フォルダのダイアログのところで質問なのですが
途中までアドレスが決まっているものは、
デフォルトで表示させて参照ボタンを押したとき、
そこからダイアログを開くこともできますか？
またお時間あるときにご教授お願いします。
>ユーザーフォーム自分で手作りで作るのが当たり前だと思っていました もちろん、普通は手作りです。
デザインをこのような場所では伝えにくいのでコードで成形しただけです。
>途中までアドレスが決まっているものは、デフォルトで表示させて参照ボタンを押したとき、 >そこからダイアログを開くこともできますか？
これは
>With Application.FileDialog(msoFileDialogFolderPicker)
という行が
Private Sub CommandButton1_Click()
Private Sub CommandButton2_Click()
の２つのプロシージャの中にありますから
２カ所とも、その次の行に
.InitialFileName = "D:\test\"
の１行を追加してください。
もちろん、パスは御自身の環境に合うように変更してくださいね。 これで解決してそのままでも結構ですが、 ちゃんと理解されてご自身の力にしたいのであれば、コードを読み解いてみてください。 理解できるまで何カ月でもお付き合いしますから。 （ｍｏｍｏ）
アドレス指定もできました！
これから手作りフォームでもちゃんとできるか試すつもりです。
ファイルのコピーもできました！
１１月の部分を半角数字（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"
という、間に年月が入ってるタイプのものもありました。
これも対応させるにはどのようにすればいいのでしょうか？
まだまだやらなくてはならないところがあり、本ではなかなか載っていないところもあります（＞＜）
これからもご教授お願いできますでしょうか？
どうぞよろしくお願いします
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に入れたものが置換されますが 複数ある場合に、どのようなインターフェースで対応させたいですか？ それともルールは固定ですか？
というように、コードを書く時は色々な事を想定して書かないといけないんですよね。 イレギュラーな事をどこまで想定して、どのように対応させるか という決めごとを少し考えてみてください。 今後役に立ちますから （ｍｏｍｏ）
今ユーザーフォームは
ｍｏｍｏさんのとおりに作りなおしました。
この方がフォルダを自分で指定できますし、年月が変わっても関係なくできます。
やはり、フォルダがない場合はフォルダを作成せず、その場所に
ファイルだけコピーされてしまう状態です。
また、置き換え後（TextBox3と4）にはファイル名がでるかと思っていたのですが
フォルダ名１０月（TextBox3）１１月（TextBox4)という風にでます。
できれば、ファイル名が一覧で出てくれるとありがたいです。
インターフェースはこのままで行きたいと思います（＾＾）
ファイル名を表示させるのであれば、TextBoxではなくListBoxを使ってみてはどうでしょう？ 左側に現在のフォルダのファイルを一覧表示させて 置換ボタンで右側のListBoxに置換後のファイル一覧を表示
置換もTextBoxでどの文字をどのように置換するかを指定させるようにして そうすればどんなイレギュラーな日付でも対応できますし。
で、すべて確認後に一括コピーとか
そんな仕様はどうでしょうか？ それでよければ、ちょっと時間をもらえればサンプルコード書いてみます。
いずれにしても、ここから先は細かい仕様をどう作りこんでいくかという方向になりますから 色々な場面を考えてみてください。 （ｍｏｍｏ）
ListBox使ったことがないので、ぜひ試してみたいです。
ファイル名の確認をしたのですが、"9月xxxxxxxxx.xls"タイプと"xxxx（1109）xxxxx.xls"の
２種類だけのようです。
ですが今後絶対とは言い切れないので、
イレギュラーなものに対応できたらうれしいです。
ファイル名の変換ができたあと、
今度はコピー元の（前月）ファイルからコピー先（今月）へ決まった列へ
数値のコピーして張り付けたり、空白にしたりという作業があります。
リンクしている数式も今月ファイルのものへ変換させたいのですが
実際できるのかよくわかりません。。
それをどのタイミングでやればいいのか、その他ご指導頂ければと思います。
フォームはこうでなければダメとかはありませんので
適宜変えても大丈夫です
よろしくおねがいします（ｖｖ）
ちょっと手間を取る時間が無いので少し時間をください。
あと、追加の分については可能かどうかで言えば可能です。 全てのファイルの中を変更するのであれば どのようなパターンでどこをどのように変更するのか （全てのファイルが同じではないですよね？それがファイル名とかで解るのかという事です）
そのようなルールとか仕様とか呼ばれるものを、つらつらと書いてみてください。 それがコーディングの第一歩です。 （ｍｏｍｏ）
内容を変更するファイルは決まっています。
今自宅なのでファイル数があいまいですが、１０個中７個ぐらいの割合だったと思います。
たとえば、コピー元（前月）のK列をコピー先（当月）J列にペーストして
そのコピー先のK列は空白にします。
損益計算書のような表３つ縦にならんでおり、
K列が今月、J列が先月のデータとなっているのでそのような作業をしたいのです。
貼りつけるものは数値で値貼り付けです。
間にSUMや率の数式が入っているので、値貼り付けする行はとびとびですが
セルは決まっています。
そしてすべてのファイルが同じフォーマットなので作業は共通となります。
金曜日、会社へ行きましたら列と行、フォーマット等の
具体的なものをまとめてまいります。
よろしくおねがいします。
ファイルをコピーした後の作業から書きます。
\x{fffd}@リンク先の更新（すべてのファイル共通）
＜作業＞リンク先のファイルはコピー元（先月）のファイルからリンクになっており
この2種類のファイル名"9月xxxxxxxxx.xls"、"xxxx（1109）xxxxx.xls"を今月に変更
\x{fffd}Aコピー、値貼り付け（決められたファイル）
この作業を行うファイルは13個中9個です。
"xxxx（1109）xxxxx.xls"タイプの２ファイルのみ複数ワークシートがあり、
フォームはすべて共通
＜作業＞
・コピーしたファイルより、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関数が入っています）
\x{fffd}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
作業内容を書きましたが、説明不足なところなどご指摘ください。
\x{fffd}Aなどは、ファイルをどのように指定すればいいのか。
実行中はプログレスバーを出したい。
・・・自分ではできないのですが、このような疑問だらけです。
ご指導宜しくお願いいたします。
えっと、フォームの部分はまだ置いておいて プログレスバーも、ちょっと置いておきましょう。
ファイルコピーした後の作業という部分ですが １つ１つ部分的に考えてコードにしてみましょう。
１．対象ファイルを開く これはどのファイルが対象であるかをチェックしながら開く作業 ・ファイルのルールによって開く必要がある ・全てのファイル？ ・13個中９個はどのように判別する？ というルールを決めてください。 あと、ファイルを開くという作業をマクロの記録を取ってみてください。
２．コピー値貼り付けの部分 ほとんどマクロ記録で取れると思うのでそれを成形していく作業 まずは1度その作業を記録を取ってみましょう
３．項目に表示されている月を変更 これは言われている事の意味が良くわかりません。 セル範囲についてもわかりにくいです。 A1:C10などの書き方にしてください。
ゆっくりですが確実に進めていきましょう。 （ｍｏｍｏ）
１．対象ファイルを開く
・全てのファイル？⇒コピぺ作業は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
２．コピー値貼り付けの部分
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つ縦に表がならんでおります。
最初は、Ｅ5の数字だけかえて、10月は=Ｅ5+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 実績 予算 予算計 ２Ｑ見通し ３Ｑ見通し 前回 今回 差異 差異 ２Ｑ差異 ３Ｑ差異 差異 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
うまくご説明できずに申し訳ございません。。
どうぞよろしくお願いします
>ファイル名で判別できますが、ファイル名の月が毎月変動 どのようなルールで判別できますか？
>ファイルを開く作業のマクロはこんなカンジでいいでしょうか？ 開くだけなら良いのですが、開いてデータを修正して・・・となるので まだそのコードは置いておきましょう。
> ２．コピー値貼り付けの部分 は、以下のように整理できますね。 変数の部分を開いたブックに合わせられるようにくっつけていきます。
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
３は・・・すみません。ちょっと説明だけでは状態がわかりません。 もう少し説明お願いします。 または実際にデータを手で直す作業をマクロ記録を取ったものを張り付けてもらっても大丈夫です。
（ｍｏｍｏ）
セルの結合部分は省きましたが、ファイルをコピー後、
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
程度で可能なんですけど。 まずはファイルを開かないと始まらないので
>ファイル名で判別できますが、ファイル名の月が毎月変動 どのようなルールで判別できますか？
この回答を優先して頂きたいと思っています。
たとえば●●という文字がファイル名に含まれているとか Ａ１セルに△△という文字があるファイルとか なにか決まったルールがありますでしょうか？ （ｍｏｍｏ）
セルの結合していても、範囲を指定すれば大丈夫ですか？
（自宅に戻り確認できなくて申し訳ございません。。）
For Each r In Range("B5:E5")
コピー＆ペーストする作業を含めすべての作業は
一番冒頭の方で、先月から今月へファイルをコピーでできたものを編集していきます。
このコピペする対象ファイルは、すべてのワークシートが同じフォームなので
上記であげましたB5に必ず先月の月が入っています。
ファイル名は、毎月同じものになりますが、
すべてに共通するものがありません。。
明日、会社にてもう一度確認してみます。
ファイル名をリネームするにしても、特定のファイルだけデータを処理するにしても ファイル名を一定の規則で保存する。というユーザーの認識も大切な要素だと思います。
色々なパターンに対応させようと思うとそれだけで大変なコードになりますから。
一度、その辺も含めて検討してみてください。 仕様が固まったらサンプルコードは書いてみますので。 （ｍｏｍｏ）
コピー作業を行わないファイルもすべて共通して"10月"という文字が入っています。
それではダメですよね・・・
"xxxx（1110）xxxxx.xls"このパターンのファイル名を
すべて"10月xxxxxxxxx.xls" 月から始まるものに変えました。
まず、その変更は非常に効果的です。 ファイル名を翌月に変更するのが楽になりますね^^
で、次はコピー作業を行うファイルの決まり事ですが ファイル名でわからないとすると、ミニーさんはどのようにして そのファイルを特定していますか？
その判断する決め手をプログラム化すれば良いので そのキーポイントを教えてください。 （ｍｏｍｏ）
ファイル名ごと覚えているようなカンジです。
コピー作業を行わないファイルにも、
なにか区別するようなものを付けた方がいいでしょうか？
ある程度は、こちらにあわせて変えていいと言ってもらったので大丈夫です♪
コピー作業が必要なファイルに特定の文字を付けて頂いても良いですし、 多少処理時間はかかりますが、あるシートのあるセルに特定のデータがあるなどでも構いません。
ファイル名が決まっているなら、そのファイル名を羅列しても大丈夫です。 （ｍｏｍｏ）
特定の文字を使用したほうがいいでしょうか？
たとえば、☆などの記号は使用しないほうがいいでしょうか？
☆でもなんでも大丈夫ですよ それで良ければサンプル書いてみますので少し時間をください。 #ちょっと本業が忙しいので^^; （ｍｏｍｏ）
あ・・・コードを書いていて思ったのですが データをコピーする作業は最初のシートだけですか？ シート名は固定ですか？ 違う場合はどのシートか、全てかを教えてください。
あと、コピーする作業はK7:K8をJ7:J8にコピーするだけですか？
それと、月を＋１するセルを正確に教えてください。 結合セルの場合はその旨も。
（ｍｏｍｏ）
それでは、上記まとめてご連絡いたします。
お忙しいところお時間頂きましてありがとうございます。
急いでおりませんので宜しくお願い致します！
こんにちは、その後いかがでしょうか？ 私の方は上記の内容以外はコードは書き終えています。 特に急ぐ訳ではありませんが、回答お待ちしていますね。 （ｍｏｍｏ）
作業するファイルですが
ファイルの中にワークシートが１つのものが３つ。
ファイルの中にワークシートが複数あり、その中のいくつかが対象。
という２パターンのファイルが８つほどあります。
ワークシートを選択したり、
ファイル名と同じ用に、ワークシートの名前を決まっていればできるのでしょうか？
また、セルのコピー、値貼り付け、削除する作業ですが、
列で指定できるのか、セルごとの方がいいでしょうか？
セルの間に簡単なSum関数や率を求めるような数式の入っているセルもあり、そこは
消さずに残しておきたいのですが・・・
>ファイル名と同じ用に、ワークシートの名前を決まっていればできるのでしょうか？ なにかしらのルールがあれば出来ます。 ファイル名に特定の文字があったり、 そのシートの特定のセルに特定の文字があるなどのルールです。
>列で指定できるのか、セルごとの方がいいでしょうか？ 途中に結合セルや非表示セルが無ければ列でも大丈夫だと思います。
>セルの間に簡単なSum関数や率を求めるような数式の入っているセルもあり、そこは >消さずに残しておきたいのですが・・・ そこを除いてセル範囲でコピペもできますし、 全部コピーしてからそのセル以外を消すとか あとは、全部消してからそのセルに計算式をＶＢＡで入れてしまうのでも大丈夫です。
その辺は考え方次第なので仕様を決めてみてください。 （ｍｏｍｏ）
それではワークシートを確認してみます。
全部コピーしてからそのセル以外を消すのを選んだ場合は、
数式の入っているセル番地を指定するのでしょうか？
それを含めてファイル確認してきます（＾＾）
コピーする範囲、消す範囲、それぞれ明確にしてみてください。 （ｍｏｍｏ）
範囲まとめてきましたので、見て頂けますでしょうか？
カッコの中はセル番号です
ところどころぬけているところは数式が入っているので
できれば、そのままにしておきたいところです。
\x{fffd}@コピー K、V、AG列（K、V、AG7～8、11～13、17～29、38～39、51～53、55～60、65～73）
\x{fffd}A貼り付け J、U、AF列（J、U、AF7～8、11～13、17～29、38～39、51～53、55～60、65～73）
\x{fffd}B値削除 K、V、AG列（K、V、AG8、11～13、17～29、38～39、51～53、55～60、65～73）
７行目は数式が入っているので、\x{fffd}A値貼り付けまではしますが
\x{fffd}B値の削除はしません。
ワークシートが複数ある場合は、ワークシート名が2文字の場合
この作業をでした。
たとえば"BK"、"WT"のような名前です。
これではダメでしょうか？
複数ワークシートがない場合は、名前に決まりはなく
シートが1枚しかありません。
宜しくお願いします。
わかりました。 とりあえず書いてみます。 ２，３日忙しいので少し時間をください （ｍｏｍｏ）
よろしくおねがいします
お待たせしました。
新規ブックで試してください。 なお、試しにコピーするフォルダのブックは必ずバックアップを取ってから試してください。
準備として 新規ユーザーフォームに 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
（ｍｏｍｏ）
実行したところ下記ができませんでした。
こちらで何か手順が違うのかもしれません。。
\x{fffd}@新しいフォルダが作成されない（ファイルは大丈夫でした）
\x{fffd}Aコピーの貼付け、クリア
あと、作成されるファイルの中でファイルのリンクがあり
ファイルが開くたびにリンク更新のメッセージがでてきます。
ここはどうすればいいでしょうか？
できれば、ファイル内のリンクも10月から11月に変えたいのですが可能でしょうか？
（リンク先ファイルも、この作成ファイルです。）
よろしくおねがいします。
>１．新しいフォルダが作成されない ん～こちらでは作成されますが・・・ ちなみに保存場所はどこでしょうか？ ＯＳのバージョンは？
>２．コピーの貼付け、クリア ファイル名に「☆」は付いていますか？ シート名は２文字ですか？スペースなどはありませんか？
ファイルのリンクについては、もう少し詳細を教えてください。 （ｍｏｍｏ）
ｍｏｍｏさんが作成されるのでしたら、
私が何か間違っているのだと思います。
ＯＳはＸＰで、Officeは2003です。
保存場所はとりあえず自分のＤドライブに
フォルダを作ってやっています。
コピー元：D:\temp\10月
コピー先：D:\temp
●２．コピーの貼付け、クリア
カンジンなことを言っておりませんでした。
☆がついているものが除外になります。。
☆以外のファイルがコピーなどの作業対象です。
本当に申し訳ございません（ＴＴ）
コピー元：D:\temp\10月 なら、コピー先は D:\temp\11月 になりませんか？ D:\temp では元々の親フォルダですから存在するので作成されませんね。
☆以外ですか、失礼しました。
コード内の
> If .List(i, 0) Like "*" & 作業マーカー & "*" Then
という所があるので
If Not .List(i, 0) Like "*" & 作業マーカー & "*" Then
~~~と、Notを追加してください。
（ｍｏｍｏ）
私が手作業で選択しなおしていたため作成されなかったみたいです。
それと申し訳ございません。
値貼付けする位置が隣の列ではなく、-12個ずれました。
Ｖ列をコピーして、それをＪ列にペースト
ＡＧ列をコピーして、それをＵ列にペースト
その後空白にするのは、Ｋ，Ｖ，ＡＦ，ＡＧです。
下記辺りからだというのはなんとなくわかるのですが、
怖くてさわれません・・・
For Each myArea In .Range("K7,V7,AG7").Areas
myArea.Offset(, -1).Value = myArea.Value
コピーの作業もできていました！
これからまた全部ファイル確認してみます！
ん？ フォルダはＯＫ、ファイルのコピーもＯＫですね？ あとは値の貼り付け位置が違うという事でしょうか？ Ｋ列とＡＦ列はコピーせずに消してしまって良いという事ですか？ あと、行番号は変わらないですね？
という条件だとしたら 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
（ｍｏｍｏ）
あと、Ｋ列とＡＦ列コピーしませんので、入替えましたらできました！
個々のファイルにあるリンク先の更新は、手作業でやるしかないのでしょうか？
それと未熟でおはずかしいのですが、教えてください。。。
ワークシートが複数あって、
コピー作業をするのはワークシート名が2文字の場合は・・・というのは
コードのどの部分でしょうか？
ひとつひとつ調べながらですが、理解できるよう苦戦してます（－－；）
>コピー作業をするのはワークシート名が2文字の場合は・・・というのは >コードのどの部分でしょうか？
これは以下の部分ですね。 If Len(ws.Name) = 2 Then シート名の文字の長さが２の時に・・・という分岐条件をしています。
>できれば、ファイル内のリンクも10月から11月に変えたいのですが可能でしょうか？ の件は >ファイルのリンクについては、もう少し詳細を教えてください。 と回答していますが、もう少し詳細に教えてください。 ・リンクとはどんなリンクなのか ・具体的なセル位置と参照先 ・置換のルールなど
たとえば、変更するリンク部分は何をさしていますか？ パスですか？ブック名ですか？シート名ですか？ Ctrl+Fの置換で出来る内容ですか？ （ｍｏｍｏ）
なんとなくしかわからないので
またコードでわからないところがあったら教えてください（ｖｖ）
・リンクとはどんなリンクなのか
>コピー元のフォルダに入っている先月ファイルになっています。
・具体的なセル位置と参照先 >いろんなセルに入っています。すべて確認した方がいいでしょうか？
・置換のルールなど >10月xxxxxxxxx.xlsのファイルなので、11月（翌月）に直します。
Ctrl+Fでリンクファイルを検索すると一覧ででてきたので、
置換えもできそう？？です。
明日置換えできるか試してみます！
Ctrl+Hで置換窓を出してオプションを押して 検索場所をシートからブックに 検索対象を数式にしておいて 検索する文字列に「10月」 置換後の文字列に「11月」 で、全て置換で望み通りになりますか？ なるのであれば、それをコードにするだけですので簡単です。 （ｍｏｍｏ）
If Len(ws.Name) = 2 Then シート名の文字の長さが２の時に・・・ですが
\x{fffd}@どうしても２文字にできないシートがいくつかあり
B7セルが"売上"という文字列のもののみを対象にコピー作業をするように
変更お願いできますでしょうか？
\x{fffd}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")
\x{fffd}Bリンクは置換えでできました。
ファイル名が10月から11月に置換えするだけで大丈夫でした。
最初のファイルコピーのものがすべて対象になります。
\x{fffd}Cファイルコピーの作業ですが、フォームが違うものが2つあります。
すべてあわせてくださいとお願いしたのですが、この２つだけはできませんでした。
どうすればよろしいでしょうか・・・
できるだけｍｏｍｏさんのご教授にそってやりたいと思っていますので
よろしくおねがいします。
１．If Len(ws.Name) = 2 Then
の部分を
If ws.Range("B7").Value = "売上" Then
に変更してみましょう。
wsという変数でシートをループしていて、そのシートのB7セルが"売上"の場合という意味になります。
２と３は、以下をまるっと差し替え どこが違うか確認してください。
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
４．は・・・どのように何が違うのかを明確にしてみてください。
（ｍｏｍｏ）
ありがとうございます！
できあがる直前で変更になってしまい、不愉快にさせてしまうのでは…と心配でした。
４についてですが
作業自体は、コピーして貼り付け、セルのクリアと同じなのですが、
作業列が違います。
ワークシート名と、列の詳細を明日まとめてまいります。
お手間おかけしますがよろしくおねがいします。。
セルの範囲も細かく必要ですが、それ以上に必要なのが そのイレギュラーファイルを特定するポイントです。 ☆がついていないファイルの中から、その特定の２ファイルだけを 見分けるルールを決めてくださいね。 （ｍｏｍｏ）
＜コピー作業をするシート＞
\x{fffd}@シート名が”差額”
\x{fffd}Aシート名が”システム”
\x{fffd}Bシート名が”会社差額”
\x{fffd}C上記以外のシート⇒すでに対応ずみのものです。
●コピー作業の詳細
\x{fffd}@シート名が”差額”
Ｒ列をコピーして、Ｅへ値貼付け
ＡＣ列をコピーして、Ｑへ値貼付け
その後、Ｆ、Ｒ、ＡＣ列を数式以外のセルをクリア
行番号は （7：8、11：13、17：29、38：39、43、51：53、55：60、65：73）
※Ｄ7セルが売上高から始まりますが、このシート名を優先になるようにお願いできますか？
※このファイルの中には、\x{fffd}Cのものも混ざっています。
\x{fffd}Aシート名が”システム”
Ｋ列をコピーして、Ｄへ値貼付け Ｑ列をコピーして、Ｊへ値貼付け その後、Ｅ、Ｋ、Ｐ、Ｑ列を数式以外のセルをクリア
行番号 （4：27、34：57、64：88、95：119、155：170、179：190、198：208、217：224、233：240、249：262、270：273）
\x{fffd}Bシート名が”会社差額”⇒コピー作業などはなく何もしない。除外
\x{fffd}C上記以外のシート ⇒済み（Ｄ7が売上で始まるもの）
何か説明が不明なところなどあれば、ご指摘ください。 よろしくお願いします
少し質問です。
処理順に １．ファイル名に☆が無ければ 質問１：これは変わらず？
２．シートが１つならシート名やセルに関わらず必ず丸４を実行 質問２：これは変わらず？
３．シート名が差額なら 丸１を実行 （丸付き数字は使いません）
４．シート名がシステムなら 丸２を実行
５．シート名会社差額はセルに「売上」があったとしても除外
６．それ以外でＤ７セルが売上で始まるものは前回の処理 質問３：セルがＢ７からＤ７に変更になったのですか？ 質問４：セルの内容が「売上」ではなく、「売上」から始まるもの？ つまり「売上だよ～」でも実行？
以上、処理手順の確認と４つの質問に回答お願いします。 （ｍｏｍｏ）
処理順はこれで大丈夫です １．ファイル名に☆が無ければ 質問１：これは変わらず？ ⇒はい、変わりません
２．シートが１つならシート名やセルに関わらず必ず丸４を実行 質問２：これは変わらず？⇒はい、変わりません。
３．シート名が差額なら 丸１を実行 （丸付き数字は使いません）⇒はい、丸1実行です。
４．シート名がシステムなら 丸２を実行⇒はい、その通りです。
５．シート名会社差額はセルに「売上」があったとしても除外
６．それ以外でＤ７セルが売上で始まるものは前回の処理 質問３：セルがＢ７からＤ７に変更になったのですか？⇒すみません、間違えました！Ｂ7セルです。 質問４：セルの内容が「売上」ではなく、「売上」から始まるもの？ つまり「売上だよ～」でも実行？
⇒それでは、”売上高”という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
（ｍｏｍｏ）
早速ためしてみました！
すると、当月のファイルを開いて作成している途中で
リンク更新のダイアログがでてくのですが、更新しないを選択して
うまくいっていたのですが、書き換え後、値の更新というダイアログが開き
ファイルを選択しなければいけなくなります。
それをキャンセルすると何もかたまって操作ができなくなるという現象が起きます。
そうですかぁ もう一度リンクについて確認します。
リンクの更新は、☆が付いていないブックの 全てのシートの全てのセルについて 「１０月」などのファイル名更新部分を 「１１月」のように次ぎの月に変更する。
という仕様で間違いないですか？ その他で更新してはいけない部分や更新しなければ行けない所は無いですか？ （ｍｏｍｏ）
リンクの更新は前月の月を当月に変えるで間違いありません。
作成するファイル以外はリンクしないようにしたので
大丈夫です。
よろしくお願いします。
どのようなリンクが張られているのかわからないので推測ですが ファイル名を変えながら移行していますから まだ出来ていないファイル名へのリンクがされている可能性がありますね。 再計算とメッセージを抑えて・・・
以下を差し替えるとどうですか？
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
（ｍｏｍｏ）
ご質問見落としておりました。申し訳ございません（汗）
まだ全部確認したわけではないのですが、それ以外は大丈夫そうです。
>リンクの更新ですが、☆がついていないファイルも対象でした。 あら・・・ ☆が付いて無いものもという事は、 全てのファイル、全てのシートという事ですか？ 根本の分岐条件が変わるので明らかにしたいです。 （ｍｏｍｏ）
コピー作業のために☆をつけたのですが、
そのほかの作業はファイル、シートすべて対象です
本当に申し訳ございません！！
もし難しいのであれば、手作業の覚悟をします（－－；）
特に難しくはないですよ。むしろ簡単になります。 ただ、最初からそのように考えるのと、途中からロジックを変更するのでは 多少無駄が出たり、コードの流れの考え方に統一性が無くなる事もあるのでご容赦お願いします。
以下、すべて差し替えで試してみてください。 相変わらず多忙に付き、テストしてません。 頭の中で動かしてるのでボケてる所があるかもしれません。^^;
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
（ｍｏｍｏ）
こんにちは お忙しいのかな？ あわてずじっくり検証して結果を教えてくださいね。 （ｍｏｍｏ）
結果のご報告できませんで申し訳ございません。
ご連絡しなきゃ、と思いつつ時間がたってしまいました。
ローカルにコピーしてやっていたもので(汗）
本番前に、変更したファイル名やリンクなどを確認しているところです。
また準備ができ実行しましたら、ご連絡申し上げます。
以前ｍｏｍｏさんにお世話になったものです。 またｍｏｍｏさんにお会いできればいいのですが・・・
やっと作って頂いたVBAが4月から運用できることになりまして、若干変更部分でてきたので 自分あれこれやってみたのですが、どうにもできずご教授いただければと思います。
＜変更点＞ 参照元、参照先のパス、フォルダ名の変更
参照元：C:\2月\売上販売\売上販売＿2月＿確定 参照先：C:\3月\売上販売\売上販売＿3月＿確定
参照先の"\売上販売＿3月＿確定"は作られていないので、コピー作業時に作成する必要があります。 その中にエクセルファイルが格納されていきます。 以前は、C:\2月⇒C:\3月へコピーでしたので、格納場所がだいぶ奥になってしまいました。
ｍｏｍｏさん、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
で、どうでしょうか？ 最近多忙で細かく解説できなくてすみません。 （ｍｏｍｏ）
お忙しいところ、回答頂き本当にありがとうございます。 試してみたところ、ファイルのコピーできました！
参照先のフォルダが作成される際、月を翌月にすることは可能でしょうか？ 現在は、参照元も参照先のフォルダとも"売上販売＿2月＿確定"と同じフォルダ名がに なっています。
参照元：C:\2月\売上販売\売上販売＿2月＿確定 参照先：C:\3月\売上販売\売上販売＿3月＿確定 ⇒翌月にしたい。
ファイルの方はすべて翌月でコピーされていました（＾＾）
お時間あるときでかまいませんので、宜しくお願いいたします
上記こちらの勘違いでした。 申し訳ございません。（＾＾；）
あともうひとつご相談です・・・ コピー作業をしないように、作業マーカー"■"をファイル名につけていましたが、 Listボックスで複数選択したものをセルのコピー＆ペースト作業をしないようにできますか？ 今は個別にファイル名を変更できるようになっています。
何か除外ボタンみたいを増やしてもいいので、何かご提案いただければと思います。 ファイル自体のコピーは翌月の名前をつけて必要となります。
すみませんが、ほとんど時間が取れないので・・・ とりあえずは、ファイル名の変更で作業マーカーを付けて頂く事でお茶を濁してください。
一番簡単な方法でご自身でもくめるかな？と思うのは ・ボタンでもなんでも良いので作業マーカーを付ける ・ファイル保存時に作業マーカーを消す という段取りで組むのが簡単だと思います。
ListBoxにオプションボタンを付けて判定でも良さそうですね。 できればここまでの課程で得られた事を参考に 少し頑張ってみてください。
決して見捨てるような事は致しませんので。 とりあえず今は私の仕事を早めに片付けます。
#本来の仕事では無いのですが少しだけ大きめのシステム作ってます。 #8000ステップくらいのコードになりそうな・・・^^; （ｍｏｍｏ）
お忙しいところ、お返事ありがとうございます。 ListBoxの中でオプションボタンをつけて判定”が自由度があってよさそうですよね そこまでできるかやってみます（＾＾）
ｍｏｍｏさん
ListBoxにチェックボックスだけつけられました。 恥ずかしながら、これも１時間ぐらい考えました（－－；）
Private Sub UserForm_Initialize()
With Me
With .ListBox1
.ColumnCount = 2
.ListStyle = fmListStyleOption
.MultiSelect = fmMultiSelectMulti
End With
End With
End Sub
ですが、個別のファイル名修正ができなくなり、 チェックボックスの後、作業マーカーをつけて・・・の作業がもうお手上げ状態です
追記：ファイルを作成中、途中でキャンセルができるようにしたいですプ。
いろいろ検索して、プログレスバーを調べていますが、ユーザーフォームを追加して作成する方法を調べています。 ｍｏｍｏさんの手があくまで、もう少しいろいろ考えてみます。
いろいろ試行錯誤してますが・・・ まったく手がうごきません。。
ｍｏｍｏさん、お忙しい様ですね。。。
要するに、何が出来れば良いのですか？
＞コピー作業をしないように、作業マーカー"■"をファイル名につけていましたが、 この「コピー」は、新しい月のフォルダにブックをコピー ですよね？
＞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さま
ご返信遅くなってすみません。 ｍｏｍｏさんが忙しいと思い、しばらくこちらを見ておりませんでした。
私もコードのことがあまりよくわからないので、 あっているか核心はないのですが・・・
フォルダにブックをコピーし、ブックの名前を翌月に変更するのは 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)
＞作業をする人はどうやって見分けているのですか？ 私もｍｏｍｏさんも馬鹿げていると思ったので、 対象ファイルの題名に"■"をつけたのだと思います。 それは、8個ほどのファイルの中に共通する条件がないためです。 損益計算書や集計表なので、作業者は共通の何かを見分けて作業しておりません。
ｍｏｍｏさんのコメントにもありますように、 いまご多忙中で対応できないので、応急処置的なものをご提案頂いたと思うのですが ファイルの仕分けは、もしかしたら他に方法があるのかもしれません… 私は素人ですので、なんとも申し上げられないのですが。
ファイルが増減する可能性、セルの加工をするもの、しないものを 自分で設定できるように、ｍｏｍｏさんに自由度を高くしてもらっています。 ここはイレジュラーなものが発生することを考えてそうしていただきました。
＞それから（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
'------
イレギュラーな事が多い様なので シートに展開した方が楽じゃないですか？ ８つのファイルのコアに成るファイル名も シートに登録しておいて。。。 まぁ、私がユーザーフォームが得意でないのも有ると思いますが。
(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のユーザーフォームの入門ページを探してみて リストボックスに関するページを見ると 大抵は リストを設定する構文が載っていますので、それを使えば良いと思っただけですが。。。
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が発動しなくなるか 少しずつ確認してもらえますか？
１．ユーザーフォームにリストボックス一つ。 UserForm_Initialize と ListBox1_AfterUpdate のコードだけ入れて確認。 ２．コマンドボタンを一つ追加して、確認。 ３．CommandButton1_Click のコードを追加して確認。 ４．コマンドボタンを押して、左側にチェックボックスが表示された状態で確認。
(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)
リストボックスのファイルをいくつか選択してから コマンドボタン３を押してみました。
コンパイルエラーというのが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
１． ＞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) ＞に変更。
三つ変更ですよ？
この行
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個以下、以上のとき "ファイルが５個ではありません"と警告のメッセージを出すことは可能でしょうか？ よろしくお願いいたします。
＞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 と書いてあることになります。
この辺りも曖昧に成っている様に思います。
＞"ファイルが５個ではありません"と警告のメッセージを出すことは可能でしょうか？ 可能だと思いますが、現在の仕様は「自由度」を追求していると思っていますので そこから外れる事に成ってしまう様に感じます。
それなら、シート上にキーワードを設けておいて 簡単に変更出来る様にしておいた方が良いと思います。
(HANA)
HANAさん、ありがとうございます。
アドバイスを頂いて、いろいろ考えてみたんですが これが精一杯で・・・ ElseIf ws.Name <> "会社差額" And ws.Name <> "あいう*" Then これでエラーもでずに、一応”作業完了”までいきました。
＞"ファイルが５個ではありません"と警告のメッセージを出すことは可能でしょうか？ この件ですが、”チェックしてないファイルは○個です”というものなら いかがでしょうか？ 間違えないように確認だけですので、ユーザーフォームのテキストで チェックしてない数がでるだけでもかまいません。 本やネットでも調べたのですが、見つけることできず悩んでおります。
ご提案いただいたシートにキーワードは、上司に反対されてしまいました（＞＜）。 申し訳ございません。
こんなのを試してみます。
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)
ということは、私のは間違っているのですね・・・ ご提案いただいたコード、私にも理解できるのですが、 "会社差額"では成功しましたが、"あいう*"のほうは コード自体書いたことないのでどうしたらいいのか… 考えられることはすべてやりましたが MsgBoxがでないので間違ってるというのはわかるので、 私なりに何時間も調べていますが、見つけられないと途方にくれてしまい正直つらいです
Sub TEST含まない()
Dim Moji As String
Moji = "あいう" & "*" '←ここを色々変えてみる"
If Moji <> "あいう" & "*" Then
MsgBox "処理対象"
End If
End Sub
＞ 現在、処理対象外の【シート】の名前は直接コード内に書いてますよね？ 処理対象外のファイルの名前を直接コード内に書くのと、何かがそんなに違いますか？
処理対象外、処理対象も両方シート名を4つにわけて記載しています。 CopyWork ws, １と２はワークシートの編集の処理をしていて CopyWork ws, 3は、１～３にあてはまらないすべてのシート名が編集処理の対象になるので、 その数が20シートぐらいあります。ファイルによってもシート名もシートの数も違います。 その月によって対象外のファイルが増えたりすることもあるので、 おっしゃるとおり、コードのために固定できないと思います。
あと実際使ってみるといろいろ問題がでてきておりまして 私が上記できるようになったらでかまいませんので、見て頂けますでしょうか？
\x{fffd}@ファイルをコピーしてる段階だと思うのですが、ワークシートの中の前月にあたる部分が
今月に置き換わるのをやめたい。
コマンドボタン３でしょうか・・・
だいぶ上の方なのですが、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月）に 変わっています。
\x{fffd}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
＞コード自体書いたことないのでどうしたらいいのか… しかし、似たような部分は ｍｏｍｏさんが書いて下さっているコード内に有りますし 【ここですよ】ってのは、私は既に抜粋してお知らせして居るつもりです。
この話が始まった所以降を、もう一度読み直してみて下さい。
そして、一気に完成に近づけるのではなく 段階を追って作っていって下さい。
(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 "チェック１．[" & Moji & "] は「あいう」で始まっています。"
End If
If Moji Like "*あいう" Then
MsgBox "チェック２．[" & Moji & "] は「あいう」で終わっています。"
End If
If Moji Like "*あいう*" Then
MsgBox "チェック３．[" & Moji & "] は「あいう」を含んでいます。"
End If
If Not Moji Like "*あいう*" Then
MsgBox "チェック４．[" & 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
算数の計算で ５＋×３ という式がおかしいように、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) いまこちらみてびっくりしました・・・
お二人のおかげで、サンプルはうまくできたので解決いたしました。 比較演算子はまた別の質問でした。
実際のコードで考えてみましたが、これでも大丈夫なのでしょうか？ サンプルをそのまま入れただけですが・・・
For Each ws In .Worksheets
If Not ws.Name Like "あいう*" And ws.Name <> "会社差額" Then
CopyWork ws, 1
ElseIf ws.Name = "システム" Then
CopyWork ws, 2
ElseIf ws.Name = "差額" Then
CopyWork ws, 3
End If
Next ws
でも順番をかえてしまうと 次のPrivate Sub CopyWork(myWs As Worksheet, Ptn As Integer)のところも 影響でるのでは・・・といま気がつきました。 やりなおしたところ、エラーもでずうまくいったように見えるのですが 間違っていたらご指摘ください。
For Each ws In .Worksheets
If ws.Name = "差額" Then
CopyWork ws, 1
ElseIf ws.Name = "システム" Then
CopyWork ws, 2
ElseIf Not ws.Name like "あいう*" And ws.Name <>"会社差額" Then
CopyWork ws, 3
End If
Next ws
文法的には問題ないと思います。 上の二つのコードは、評価する順序は前の式からですが、干渉する条件がないので 結果はどちらも同じものになってるように見えます。 (Mook)
Mookさん、ありがとうございました！ ほとんどお力をお借りしてしまいましたが、うまくいったとき ちょっとですがおもしろいと思えました。
まだまだいろいろ問題があるのですが、書いてもいいのでしょうか。
先日、\x{fffd}@、\x{fffd}Aと少しかかせて頂いたのですが、 HANAさん見ていてくれてるといいのですが。。。
\x{fffd}@と\x{fffd}Aはちょっと難しくてわからなかったので、↓こちらだけ自分で考えました。
\x{fffd}Bファイルをコピーしている最中にリンクの更新ダイアログがでてくるのですが
そのダイアログを開かずに、すべて更新しない。にして、
ブックの数式を自動にしたかったので（ツール→オプション→計算方法のところ）、
下記のようにためしにやってみましたら、
めちゃめちゃ速度が遅くなってしまい、その上、ブックは何も開いてないのに見えないところで
ブックが開いているようです
作成したフォルダを削除しようとすると、開いてないのにブックが開いているため削除できませんと メッセージがでるのです。
Private Sub CopyProc(OpenPath As String, SavePath As String)
Dim ws As Worksheet
With Application
.DisplayAlerts = False →追加しました。
.ScreenUpdating = False
.Calculation = xlCalculationManual →xlCalculationAutomaticにしました
.DisplayAlerts = False
知識がないのに、余計なことするとこういうことになるんですね・・・
＞HANAさん見ていてくれてるといいのですが。。。 見ては居るのですが、私がレスをする事が本当に良い事かどうか迷っています。
結局、Dir関数についてとか Like演算子 について知識は増えましたか？ なぜｍｏｍｏさんのコード内では Dir( )の中に入れてあって 今回は不要だったのか。
その前の質問とそれによって完成したコードも それぞれを変える事が、どういう事か分かりましたか？
＞知識がないのに、余計なことするとこういうことになるんですね・・・ 誰でも最初は知らない事だらけです。 そして、チャレンジする事は大切な事だと思います。 しかし、実際にコードを変更する前には「考える事」が重要です。
＞ブックの数式を自動にしたかったので（ツール→オプション→計算方法のところ）、 ＞.Calculation = xlCalculationManual →xlCalculationAutomaticにしました 元のままで、何か問題が有りましたか？ 具体的には「自動に成らずに終わってしまう」等。 問題が無ければ、変更は不要です。 そして、きっと 問題無いと思います。 なぜなら、コピー作業等をする前（コードの初め）に、確かに計算方法は手動に成りますが CopyProcが終わる前には .Calculation = xlCalculationAutomatic が実行され 計算方法は手動に成って終わります。
もちろん、コード内で数式をコピーして計算結果を値貼り付けしたい 等の場合は 値貼り付けをする前に再計算しておかないといけませんが そういった訳ではないのですよね？
とりあえず、こちらでサンプルが作れる様に状況を教えて下さい。 もちろん、実際のファイルは大きいと思いますので 同じ現象が起きるブックを作成し、その作成方法を教えてください。
つなぎとしては、CopyProcでは ファイルを ＞Workbooks.Open(OpenPath) で開いています。 ヘルプで確認して貰うと、「リンクの更新をどうするか？」等 設定する所が有ったと思います。 Web検索した方が早いかもしれません。 それで制御出来ないかどうか やってみて下さい。
話は少し戻りますが ＞でも順番をかえてしまうと ＞次のPrivate Sub CopyWork(myWs As Worksheet, Ptn As Integer)のところも ＞影響でるのでは・・・といま気がつきました。 そうですね。最初に出来た方のコードでは、期待通りの結果は得られなかったと思います。 だって If ● Then ○○ ElseIf ▲ Then △△ ElseIf ■ Then □□ End If がやりたい事なのに、●と■を書く位置だけ変えて If ■ Then ○○ ElseIf ▲ Then △△ ElseIf ● Then □□ End If にしてしまったら、■の時に○○が実行されてしまいますので。
もしも順番を入れ替えるなら、やりたい事も一緒に入れ替えないといけません。 If ■ Then □□ ElseIf ▲ Then △△ ElseIf ● Then ○○ End If これだと、■の時に□□が実行されます。
今回は「Ptn」が番号に成っているので 順番に並ぶ様にしておくのが素直だと思います。
(HANA)
>結局、Dir関数についてとか Like演算子 について知識は増えましたか？
知識にはなっていませんが、実際にやって実感することができました。 後のことを考えて変更するというのも、やりながら気がつけたので とても勉強になりました。 なかなか進まなくて申し訳ないばかりですが、よろしくお願いします。
リンクの更新もネットで調べて、ダイアログがでないようにしたのですが 作業完了メッセージがでるまで、数分ユーザーフォームを見つめてるという かたちになってしまいました。 ダイアログがでた方が作業の状況がわかっていいような気がします。 上司にはダイアログがいちいちでて、その都度"更新しない"を押さないと 次にすすまないのは面倒だ。といわれたのですが…他に方法ありますか？
＞ブックの数式を自動にしたかったので（ツール→オプション→計算方法のところ）、 ＞.Calculation = xlCalculationManual →xlCalculationAutomaticにしました
ここは申し訳ございません。私の勘違いでした。 コピーされたファイルをみてみると、数式が入っている部分だけ#REF!になっています。 問題はツール→オプション→計算方法ではなく そのワークシート内の前月の部分がすべて当月に変わってしまったためだと思います 数式の入っているセルは、SUMIFで表の項目"○月"を見ているのですが、
4月 5月 6月 7月 と並んでいたものが 5月 5月 6月 7月 と前月が当月に変わってしまったため、 #REF!になってしまったと思われます。 5月に変わってしまった４月を手入力で変更すると#REF!は消えていきます。 これはCopyworkの部分になるのでしょうか・・・
＞ダイアログがいちいちでて、その都度"更新しない"を押さないと ＞次にすすまないのは面倒だ。といわれたのですが… 流石にそれでは 私でも言いますよ！！ 漸く上司の方と意見が一致する所が見つかった様に思えます。
＞リンクの更新もネットで調べて、ダイアログがでないようにしたのですが ＞作業完了メッセージがでるまで、数分ユーザーフォームを見つめてる 確認ですが、リンクの更新がでない様にする前と後で 処理速度が変わりましたか？
具体的には 「更新しない」を押さなくて良く成ったが 処理に時間がかかる様に成った 等。
でなければ、何処で時間がかかっているか考察して 時間短縮につながるコード変更が出来ないか考えて行かないと 仕様が無い様に思えます。
・・・と言う事を想像して居られるのではなく。。。ですか？ ユーザーフォームの後の画面はころころ変わるので 「処理中かどうか分からない」って事も無いのですよね？
(HANA)
＞流石にそれでは 私でも言いますよ！！ やはりそうですか～笑
＞確認ですが、リンクの更新がでない様にする前と後で処理速度が変わりましたか？ いえ、下記コードでやってみたのですが、速度的にはほとんど変わりませんでした。
＞時間短縮につながるコード変更が出来ないか考えて行かないと 私のＰＣですと結構早いのですが、別の人に試してもらったところ１０分以上もかかって キャンセルもできなくて困った・・・と言っていました。 ＰＣの性能にもよるのでしょうか・・・
私がさわったところはコメントしてあります↓ またとんちんかんなことをしてると思いますのでご指摘ください。
Private Sub CopyProc(OpenPath As String, SavePath As String, flg As Boolean)
Dim ws As Worksheet
With Application
.ScreenUpdating = False '----Falseに変更
.Calculation = xlCalculationManual '------計算方法「手動」
.DisplayAlerts = False
.AskToUpdateLinks = False '----ダイアログ停止
End With
With Workbooks.Open(OpenPath, UpdateLinks:=0) '----リンク更新しない追加
'値コピー作業
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 Not ws.Name Like "あいう*" And ws.Name <> "会社差額" 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
.AskToUpdateLinks = True
End With
End Sub
＞ユーザーフォームの後の画面はころころ変わるので 「処理中かどうか分からない」って事も無いのですよね？
ユーザフォームは画面の真ん中にあって、処理中特にプログレスバーのようなものもないので 作業完了までじーっと待つ状態です。 処理中、ディスプレイ画面も真っ白になり何も動かせないこともあります。 タスクバーを見ると、対象のエクセルファイルが立ち上がっては消え次のファイル・・・というカンジです。
変更点は問題無いと思います。
一点確認しておいて貰いたいのですが 現在、計算方法が手動のまま保存して終了していると思います。 上の方で「最後に自動にするから問題ない」と書きましたが ここが問題有る様に思えてきました。
エクセルを何も開いていない状態から コピーされたブックをダブルクリックで開いて、 オプションの計算方法が自動に成っているか みておいて下さい。
＞ＰＣの性能にもよるのでしょうか・・・ 性能に寄ると思います。 ＞処理中、ディスプレイ画面も真っ白になり何も動かせないこともあります。 これなんか特に。
性能の良いマシンに限定して使うことにするのが良いと思います。
＞処理中特にプログレスバーのようなものもないので これは、こだわって居られる様ですが 処理以外の事をやらせようとすると それだけ処理も遅くなると思います。 勿論、程度の問題だと思いますが。。。
ユーザーフォームにラベルなどを作っておいて ○／●ブック目を処理中 等の表示でしたら（何処まで追求するかにもよりますが） そう難しくなく出せるのかもしれません。
いずれにしても、このスレはだいぶ長くなってしまって コードがどの様に成っているのか探すのが大変です。
整理して新規で投稿してもらえると良いと思います。 その際 文中に、お互いのリンクを載せてもらえると良いと思います。
(HANA)
HANAさん
了解いたしました。 計算方法の手動のところ確認して、また明日新規投稿も含めご報告いたします。
>ユーザーフォームにラベルなどを作っておいて○／●ブック目を処理中 もしこれも可能でしたら、ぜひやってみたいです。
よろしくおねがいします
HANAさん、遅くなって申し訳ございません。 こちらで新規投稿いたしました。
https://www.excel.studio-kazu.jp/cgi-bin/kazuwiki2.cgi
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.