[[20110831092933]]　『エクセルでファイル名取得』（せい）　ページの最後に飛ぶ

『エクセルでファイル名取得』（せい）
はじめまして
どのように説明したらよいのか悩んでいますがやりたいことを書かせて頂きます
まず、AAA　111.xls、ABA　222.xls、といった感じのファイルが同じフォルダ内に多数あります。
それとは別のところにAAAや111が含まれるデータが１行に入力してあるファイルがあります。

 - - - - - - - -
 AAA | 111 | III
 - - - - - - - -
 ABA | 222 | OOO
 - - - - - - - -
 AAA | 111 | SSS
 - - - - - - - -

といった感じです。これはどんどん増えていきます
そこで、この入力したAAA、111をファイル名としたエクセルファイルを探しその中の
sheetAの任意の場所にその１行をコピーさせるといったことがしたいことです
このAAA、111などはIIIなどがいろいろある為、AAA、111がある行をすべてコピー
できないといけないのですが、どのようにしたらよろしいでしょうか
説明が不十分かもしれませんがよろしくお願いします。

エクセル２０００
ＷＩＮＤＯＷＳ　ＸＰ

 できるけど、【その中の sheetAの任意の場所にその１行をコピー】という、その【任意の場所】とは
具体的にどこ？　あるいは、その場所を、どのように指定する？

 (ぶらっと)

早速の対応ありがとうございます
任意の場所とはＬＡＮ上のＨＤＤの中にシートというフォルダがありそこにAAA　111.XLSやABA　222.XLSなどの
ファイルがあり、またそれぞれのエクセルファイルにA(Aは全部のXLSファイルにあります）というシートがありそのシートの２行目から下へコピーしていきたいです。入力するシートはデスクトップに保存してあり内容が増えていきます
入力すると２行目３行目と前のは消えずに増やしていくような感じです
指定の仕方ですがパス名で出来ればと思っています
以前アクセスでＤＩＲ関数をつかったことがあり似たようにはできないかと・・・

 質問ばかりしないで早く回答を！　とイラつくかもしれないけど、４点。

 １．まず、一番重要なこと。
　　たとえば　AAA/111 で　ABC というデータがあって、それを対象のブックにセットしたとする。
　　で、次に、AAA/111 で　XYZ というデータを追加して、この処理をすると、AAA/111 の ABC はセット済みだから
　　転記対象とはならず、AAA/111　の　XYZ　「だけが」追加される。こういうことだよね。
　　この、AAA/111 で　ABC　を転記対象からはずす判断基準はどう考えているかな？
    １）一般によく用いられるルール。どこかの列（複数列の組合せでもいい）を「キー」として、その「キー」が
　　　　すでに転記先に存在するかどうかで判定。
　　２）転記元のどこかに判断列を持っておき、転記したら転記済みマークを設定。転記済みマークがあるものは
　　　　転記対象からはずす。
　　３）できるけど、感心しない方法としては、行のすべてのセルが、転記元、転記先で同じなら転記済みとみなす。
　　４）全く発想を変えて、処理の都度、転記先シートをクリアした上で、転記元から「全行」転記。
　　　　（処理としては、これが一番シンプル）

 ２．AAA 111.xls このAAA と 111 の間は　「１桁の半角ブランク」？

 ３．転記元のブックは、これから準備するマクロが書かれるマクロブック？
　　それとも、それとは別のデータブック？（個人的な好みとしてはこちらのほうがおすすめ）
　　もし、別ブックだとしたら
　　１）それは、マクロとは別に操作者がエクセル上で開く？
　　２）マクロの中で、ダイアログを表示して選ばせる？
　　３）フォルダ、ブック名をマクロの中で固定して、それを開く？
　４．転記先ブックのフォルダは
　　１）フォルダ選択のダイアログから選ばせる？
　　２）マクロの中で、フォルダパスを固定？

 (ぶらっと)

おはようございます
こちらから教えて頂いているのにいらっとなんてしませんよ
いろいろ質問して頂いた法が勉強や確認にもなるし逆にありがたいです

質問の答えですが
１、転記する内容としては
＞AAA/111 の ABC はセット済みだから転記対象とはならず、AAA/111　の　XYZ　「だけが」追加される
この通りです
判断基準としては２）で出来るとわかりやすそうです

２、全角スペースです

３、この辺はほとんど理解していない部分です
特別な操作はせずに扱えれば幸いです

４、パスにしたいです

 こんな感じかな。AAA/111 なんかが記載されているブックの標準モジュールに以下を。
とりあえず、処理済マーク列をＸ列にしてある。またフォルダは適当な名前にしてある。
これら（★マーク）のところは、実際のものに変更してね。

 Sub Sample()
    Const shName As String = "SheetA" '抽出ブックの対象シート名
    Const doneCol As String = "X"     '★コピー済みフラッグの列記号。お好きな列を設定してね。

    Dim myPath As String
    Dim myBook As String
    Dim dBook As Workbook
    Dim i As Long, z As Long
    Dim c As Range

    Application.ScreenUpdating = False

    myPath = "C:\TEST\"              '★抽出ブックのフォルダ　適切なものに変更してね。

    Set dBook = ThisWorkbook
    With dBook.Sheets(1)
        z = .Range("A" & .Rows.Count).End(xlUp).Row
        For Each c In .Range("A1:A" & z)                  'ブック名記述情報を取り出す
            If Len(.Cells(c.Row, doneCol).Value) = 0 Then '未転記データのみ対象。
                myBook = c.Value & "　" & c.Offset(, 1).Value & ".xls" 'ブック名の生成
                If Len(Dir(myPath & myBook)) > 0 Then     'フォルダ内に存在する場合のみ処理
                    Workbooks.Open myPath & myBook
                    If Not IsObject(Evaluate(shName & "!A1")) Then   '念のためシートの存在チェック
                        MsgBox myBook & "には" & shName & "が存在しません"
                        ActiveWorkbook.Close False
                    Else
                        With ActiveWorkbook.Sheets(shName)
                            .Range("A" & .Rows.Count).End(xlUp).Offset(1).EntireRow.Value = _
                                                                            c.EntireRow.Value
                        End With
                        ActiveWorkbook.Close True
                        .Cells(c.Row, doneCol).Value = "済"
                    End If
                Else
                    MsgBox myBook & "が指定フォルダに存在しません"
                End If
            End If
        Next  '次のブックを。
    End With

    Set dBook = Nothing

    Application.ScreenUpdating = True
    MsgBox "処理が完了しました"

 End Sub

 (ぶらっと)

すいませんやってみましたがうまくできないので
説明をもう一度してみます

下のが毎回増やしていくシートです
book1(入力シート）

　　A 　 B 　　C 　　D 　　E

1 番号番号2 番号3 番号4　　　

2 1 　 AAA 　111　 A1A

3 1 　 BBB 　 222 　 A2A

4 2 　 AAA 　 111 　 A3A

5 3 　　CCC　 333 　A4A

|sheet1|

このように番号(A)は同じ物もありＢとＣでフォルダＡにファイルを作ってあります

フォルダＡ

　　｜

AAA　111.xls

BBB　222.xls

CCC　333.xls

このなかの
AAA　111.xls （book2）に

    A B C D E

1 1 AAA 111 A1A

2 2 AAA 111 A3A

      |sheet2|

このようなシートがあります

book1に入力したデータをフォルダＡの中から探し、たとえばAAA　111.xls
ならそのbookのsheet2にコピーするという物です

見づらくてすいません

 まず、Ａ列が番号でブック名要素はＢ列とＣ列って、これまでの説明になかったね。
最初の行がタイトル行というのも、はじめて。ブックへのアクセスキーのポイントのところだよ。

 コードが想定していたレイアウトが違うので「うまくいかない」ということは当然なんだけど、（今後のためにも）
うまくいかないだけじゃなく、エラーで中断するとか、エラーメッセージがでるとか、処理が終わってもブックに変化がないとか
そんなふうに説明しないと、回答側では、なかなか状況をつかめないことになる。

 それと、「sheet2にコピー」、これまでの説明では「またそれぞれのエクセルファイルにA(Aは全部のXLSファイルにあります）というシート」
どっちなのかな？

 (ぶらっと)

 説明のあったレイアウトに対応させた。
コードの中の★マークが記載されているもの（４つ）は、せいさんのほうで、正しい値に直してね。

 Sub Sample()
    Const shName As String = "A" '★抽出ブックの対象シート名
    Const doneCol As String = "X"     '★コピー済みフラッグの列記号。お好きな列を設定してね。

    Dim myPath As String
    Dim myBook As String
    Dim dBook As Workbook
    Dim i As Long, z As Long
    Dim c As Range

    Application.ScreenUpdating = False

    myPath = "C:\TEST\"              '★抽出ブックのフォルダ　適切なものに変更してね。

    Set dBook = ThisWorkbook
    With dBook.Sheets("Sheet1")      '★AAA 111 が記述されているシートのシート名
        z = .Range("A" & .Rows.Count).End(xlUp).Row
        For Each c In .Range("B2:B" & z)                  'ブック名記述情報を取り出す
            If Len(.Cells(c.Row, doneCol).Value) = 0 Then '未転記データのみ対象。
                myBook = c.Value & "　" & c.Offset(, 1).Value & ".xls" 'ブック名の生成
                If Len(Dir(myPath & myBook)) > 0 Then     'フォルダ内に存在する場合のみ処理
                    Workbooks.Open myPath & myBook
                    If Not IsObject(Evaluate(shName & "!A1")) Then   '念のためシートの存在チェック
                        MsgBox myBook & "には" & shName & "が存在しません"
                        ActiveWorkbook.Close False
                    Else
                        With ActiveWorkbook.Sheets(shName)
                            .Range("A" & .Rows.Count).End(xlUp).Offset(1).EntireRow.Value = _
                                                                            c.EntireRow.Value
                        End With
                        ActiveWorkbook.Close True
                        .Cells(c.Row, doneCol).Value = "済"
                    End If
                Else
                    MsgBox myBook & "が指定フォルダに存在しません"
                End If
            End If
        Next  '次のブックを。
    End With

    Set dBook = Nothing

    Application.ScreenUpdating = True
    MsgBox "処理が完了しました"

 End Sub

混乱させてしまい申し訳ありません
それぞれのエクセルファイルにA(Aは全部のXLSファイルにあります）というシート
AAA　111.xls BBB　222.xls CCC　333.xls ・・・・
これらに材料履歴というシートがあります

再度いただいたコードをいれてみました
結果、実行時エラー'9'となりインデックスがありませんという
エラーがでました
１行ずつ実行したら
z=というところでエラーになりました

４カ所の変更箇所をなおした物が

Sub Sample()

    Const shName As String = "材料購入" '現在すでに１６０行データがあります
    Const doneCol As String = "M"     '★コピー済みフラッグの列記号。

    Dim myPath As String
    Dim myBook As String
    Dim dBook As Workbook
    Dim i As Long, z As Long
    Dim c As Range

    Application.ScreenUpdating = False

    myPath = "C:\Documents and Settings\E85W\デスクトップ\ドキュメント\エクセル\MC2\"      'AAA 111.xls    BBB 222.xlsなどが保存してあるフォルダ

    Set dBook = ThisWorkbook
    With dBook.Sheets("購入履歴")      '★AAA 111 が記述されているシートのシート名
        z = .Range("A" & .Rows.Count).End(xlUp).Row
        For Each c In .Range("B2:B" & z)                  'ブック名記述情報を取り出す
            If Len(.Cells(c.Row, doneCol).Value) = 0 Then '未転記データのみ対象。
                myBook = c.Value & "　" & c.Offset(, 1).Value & ".xls" 'ブック名の生成
                If Len(Dir(myPath & myBook)) > 0 Then     'フォルダ内に存在する場合のみ処理
                    Workbooks.Open myPath & myBook
                    If Not IsObject(Evaluate(shName & "!A1")) Then   '念のためシートの存在チェック
                        MsgBox myBook & "には" & shName & "が存在しません"
                        ActiveWorkbook.Close False
                    Else
                        With ActiveWorkbook.Sheets(shName)
                            .Range("A" & .Rows.Count).End(xlUp).Offset(1).EntireRow.Value = _
                                                                            c.EntireRow.Value
                        End With
                        ActiveWorkbook.Close True
                        .Cells(c.Row, doneCol).Value = "済"
                    End If
                Else
                    MsgBox myBook & "が指定フォルダに存在しません"
                End If
            End If
        Next  '次のブックを。
    End With

    Set dBook = Nothing

    Application.ScreenUpdating = True
    MsgBox "処理が完了しました"

 End Sub

です
勘違いしてそうなきがものすごくします
'材料購入'がその都度入力するシートです
'購入履歴'が購入のシートに書いた情報が反映されるシートです
C:\Documents and Settings\E85W\デスクトップ\ドキュメント\エクセル\MC2\は
購入履歴のシートがあるxlsファイルがあるフォルダです

(Ｂ列)　(Ｃ列).xlsというファイルをMC2フォルダからみつけてそのファイル内の購入履歴シートに
材料購入シートの中からＢとＣが一致している行を購入履歴シートに抽出する形

この操作で変更箇所があっているかすいませんが確認お願いします

 エラーは、z = のところじゃなく、その１つ上の　With dBook.Sheets("購入履歴") のところだったでしょ？
ちょっと、表現がややこしかったかな？　オリジナルコード内のコメントで【抽出ブック】といっているのは
"C:\Documents and Settings\E85W\デスクトップ\ドキュメント\エクセル\MC2\"　に保存されていて処理時に抽出されるブック。

 今回の場合、【材料購入】がその都度入力するシートということだから、これは、抽出フォルダ内のブックではなく
このマクロブックのシート名だよね。

 なので、With dBook.Sheets("材料購入")

 逆に、Const shName As String = "材料購入" 　
これは、オリジナルコードのコメントにあるように【抽出ブック】だから

 Const shName As String = "購入履歴"　にしなきゃいけない。

 ところで、

 "C:\Documents and Settings\E85W\デスクトップ\ドキュメント\エクセル\MC2\"

 まず、この　C:\Documents and Settings\E85W\デスクトップ　の部分。
E85W は、このＰＣのログインユーザーＩＤ。なので　E85W さんのＰＣならこれでいいけど
このコードを　E86Z さんのＰＣで実行するとフォルダが見つからないということになる。
絶対に、このＰＣだけで実行するんだ、あるいは別のＰＣで実行する場合は、この E85W を書き換えるんだということなら
いいけど、そうじゃないよね。

 なので、そのＰＣに適したデスクトップのパスを以下のように動的に取得する。

 myPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\ドキュメント\エクセル\MC2\"

 さらに、もし、その後の　"ドキュメント" が　マイドキュメントのことなら

 myPath = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\エクセル\MC2\"

 といったようにもかける。

(ぶらっと)

ありがとうございます

エラーはでなくなりました
しかし実行するとAAA　111.xlsがありませんとでてしまい入力してあるすべてが
ありませんになってしまいます

 myPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\ドキュメント\エクセル\MC2\"
この場所はあっているので（パスをコピーして貼り付けた）
どこが問題なのかさっぱりです。
またよろしくお願いします

 う～ん・・・このメッセージが出るということは指定フォルダにそのブックがないということなので
フォルダ名が違っているのかブック名が違っているのか、いずれかだけどね。
シート上には、全角で　ＡＡＡ　とか　１１１、実際のブック名は半角で AAA　111.xls といった場合も
一致しないけど、そこは大丈夫？

 以下を実行してみてくれる。
終わったら、ＶＢＥ画面のメニューの表示からイミディエイト　ウィンドウを選ぶと、ＶＢＥ画面の
下のほうにイミディエイト　ウィンドウが現れ、そこに、そのフォルダにあるブックが列挙されている。
そのなかに目的のブックはある？

 Sub Test()
    Dim myPath As String
    Dim fname As String
    myPath = "C:\Documents and Settings\E85W\デスクトップ\ドキュメント\エクセル\MC2\"

    fname = Dir(myPath & "*.xls")
    Do While Len(fname) > 0
        Debug.Print fname
        fname = Dir()
    Loop

 End Sub

 (ぶらっと)

実行してみたところ目的のBOOKはあります
それと、よく見ていたらBOOKがあるものは購入履歴がありません
とメッセージされました
確認してみましたがいくつかあるシート（全部で４～６（増えることもあります））
の中にはちゃんと購入履歴シートはありました
大文字小文字全角半角も見た感じでは良さそうです
大変お手数おかけしていますが引き続きお願い致します

 質問者さんへ＞
 この掲示板は、行頭に半角スペースを入れることにより 整形されます。
 <ここに半角スペース

 また、投稿時には毎回署名して下さいね～
 （とおりすがりん♪）

 すいません
はじめての投稿で解らずにしていました
これから気をつけます。

（せい）

 >大変お手数おかけしていますが引き続きお願い致します

 「お手数」は、まったく気にしないでいいんだけど、う～ん・・・・
こちらで、せいさんの環境と同じ（と想定される）ものを（フォルダだけはちがうけど）作ってテストしてるけど
正常に、転記が行われている。
実際に、そちらのフォルダ名がどうなっているのか、ブック名がどうなっているのか、セルに入っている
文字列は本当に正しいのか？

 最近のケースでは、たとえばセルに ABC と入っている。
で、これでリスト検索すると、リストにはABCがあるのにマッチしない！！
こんなことがあった。実際には、そのセルには ABCbb (bb はスペース) とあって、見た目は同じだけど
ＶＢＡから見るとABCじゃない。
シート名も　購入履歴bb なんてものだったりして。

 だけど、これらは、こちらではわかりようがない。あくまで、せいさんが調べなきゃわからない。
（コードは絶対に間違いはないよ）

 AAA 111.xls がありません　となった AAA あるいは 111 があるセルに対して、シート上のあいているところに
=LEN(そのセル) をいれてみてくれる？
AAA なら 3 とでるはず。　だけど、後ろにスペースなんかがついていると　4 とか 5　とかになる。

 で、もし、そうならシートの入力を修正してもらうのが筋だけど、
myBook = c.Value & "　" & c.Offset(, 1).Value & ".xls" 　これを
myBook = Trim(c.Value) & "　" & Trim(c.Offset(, 1).Value) & ".xls" にすると逃げることができるかも。

 でも、シート名は、コードでの手当てはできないなぁ。

 (ぶらっと)

 存在しませんとでていたのはほんとに存在してませんでした。
 ある物に関して購入履歴がありませんとでるみたいです
ちなみにそのファイル内（BOOK）にはワークシートが４個あり５番目に購入履歴というシートを
作っています。

LENをしてみましたが文字数はあっていました

（せい）

 できました！！！
コードの入れているところが違ったみたいですＶＢＡPROJECTって言うところにSHEET１とか２とか
あってSHEET1のところにコードをいれてました
 ThisWorkbookというところに移したらちゃんと動きました。
本当にありがとうございます
 ただ、毎回マクロ実行しないとだめみたいでボタンか自動でというのはできますか
重ね重ねすいません

 でもとにかく感動です

（せい）

 追記です
内容が複数になってしまうかもしれませんが
購入履歴シートが無いBOOKがありました。手作業で探してシートを追加せずに
フォルダ内のファイルにいっぺんに購入履歴シートを追加することは出来ますか。
 これも又、ある時無いときがあるので一気にできるとうれしいです
 あまえてばかりですいません

（せい）

 一歩進んだようで、よかったね。
ただ、アップしたコードは、シートモジュールでも、Thisworkbookモジュールでもなく、
｢標準モジュール｣というところに書く。
一般に、何もことわらなかったら、コードは、標準モジュールに書くね。
シートモジュールや、Thisworkbookモジュールには、エクセルの様々な動き（イベント）を
自動的にとらえて処理をする、そんな特殊なものを書く。

 で、標準モジュールって、どこ？
VBE画面のメニューで｢挿入｣、そこで｢標準モジュール｣を選んででてくるモジュール。
ここに、コードを引っ越しさせてね。

 シートにボタンを配置するのはできるかな？
エクセル画面の｢表示｣->｢ツールバー｣ででてくるなかから｢フォーム｣を選ぶ。
でてきたコントロールがいくつも入っている中で、四角形のボタンをクリック。
次に、シートの好みの場所をクリック。これでボタンが配置される。

 ボタンが配置されたら、マクロ登録のダイアログがでてくるので、
ここでプロシジャ名（アップしたものはSampleにしてある）を選んでOK。

 マクロ登録は、以下でもできる。

 ボタンを右クリック。ここでテキスト編集を選ぶとボタンの文字列を任意のものに変えることができるし
マクロの登録を選ぶと、プロシジャを登録できる。

 シートがない場合に、自動的に追加するのは、簡単。
できたらアップするけど、どんなシートがいいのかな。
空白シートでいいの？

 (ぶらっと)

 以下のコードを「標準モジュール」に。
実行したいときにいつでもどうぞ。これもボタンに登録しておいたらいいね。

 Sub シート追加()
    Const shName As String = "購入履歴"
    Dim myPath As String
    Dim myBook As String
    Dim myStr As String

    Application.ScreenUpdating = False

    myPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\ドキュメント\エクセル\MC2\"
    myBook = Dir(myPath & "*.xls")
    Do While Len(myBook) > 0
        Workbooks.Open myPath & myBook
        If Not IsObject(Evaluate(shName & "!A1")) Then
            Sheets.Add before:=Sheets(1)
            ActiveSheet.Name = shName
            ActiveWorkbook.Close True
            myStr = myStr & vbLf & myBook
        Else
            ActiveWorkbook.Close False
        End If
        myBook = Dir()
    Loop

    Application.ScreenUpdating = True

    If Len(myStr) > 0 Then
        MsgBox "以下のブックにシートを追加しました" & myStr
    Else
        MsgBox "フォルダ内のブックにはすべて" & shName & "がありました"
    End If

 End Sub

 (ぶらっと)

 おはようございます
シートの追加のコードありがとうございます
 １つ問題が発生してしまいました
標準モジュールへ移したところ
If Len(.Cells(c.Row, doneCol).Value) = 0 Then '未転記データのみ対象。
のdonecolのところで、コンパイルエラーがでてしまいました
定数式が必要ですとでているのですが何が原因でしょうか
 週をまたいでしまっていますがよろしくお願いします

 追記
すいません。あとシートの追加のときに１行目を
注番　図番　品名　材質　寸法	加工　面取り　ロール目　数量	単価　発注日　備考
と、１２列テンプレートとしたいのですがどのように追加していけば
よろしいでしょうか

（せい）

 >標準モジュールへ移したところ
 >If Len(.Cells(c.Row, doneCol).Value) = 0 Then '未転記データのみ対象。
 >のdonecolのところで、コンパイルエラーがでてしまいました
 >定数式が必要ですとでているのですが何が原因でしょうか

 【引越し】させたとき
 Const doneCol As String = "X"   '★コピー済みフラッグの列記号。お好きな列を設定してね。
 これは、どのように変更した？
 それをアップしてくれる？

 >シートの追加のときに１行目を
 >注番　図番　品名　材質　寸法　加工　面取り　ロール目　数量	単価　発注日　備考
 >と１２列テンプレートとしたい

 ActiveSheet.Name = shName と　ActiveWorkbook.Close True　の間に、以下。

 Range("A1:L1").Value = Array("注番", "図番", "品名", "材質", "寸法", "加工", "面取り", "ロール目", "数量", "単価", "発注日", "備考")
 Columns("I:J").NumberFormatLocal = "#,##0_ "
 Columns("K").NumberFormatLocal = "yyyy/m/d;@"

 なお、書式は、お好きなものを。

 (ぶらっと)

 Const doneCol As String = "M"     '★コピー済みフラッグの列記号。
としました。
備考の次の列にしようと思っています

 追加シートのコードありがとうございます

 >Const doneCol As String = "M"     '★コピー済みフラッグの列記号。

 不思議だねぇ。これだとＯＫだよ。（ほんとにこれなら）
 かつ、【定数式が必要です】のコンパイルエラーは、【でるとすれば】
 If Len(.Cells(c.Row, doneCol).Value) = 0 Then  といった実行コードのところじゃなく
 Const doneCol As String = ○○○　のところででるはず。

 たとえば
[[20091210092804]]　『定数式が必要です』（めんとす）　>>BOT
 これなんか参考になるかな。

 引越しさせたコードがある標準モジュールを、最初から最後まで、すべてコピペしてアップしてくれる？

 (ぶらっと)

 Sub Sample()

    Const shName As String = "購入履歴" '現在すでに１６０行データがあります
    Const doneCol As String = "M"     '★コピー済みフラッグの列記号。

    Dim myPath As String
    Dim myBook As String
    Dim dBook As Workbook
    Dim i As Long, z As Long
    Dim c As Range

    Application.ScreenUpdating = False

    myPath = "C:\Documents and Settings\E85W\デスクトップ\ドキュメント\エクセル\MC2\"

      'AAA 111.xls    BBB 222.xlsなどが保存してあるフォルダ

    Set dBook = ThisWorkbook
    With dBook.Sheets("材料購入")      '★AAA 111 が記述されているシートのシート名
        z = .Range("A" & .Rows.Count).End(xlUp).Row
        For Each c In .Range("B2:B" & z)                  'ブック名記述情報を取り出す
            If Len(.Cells(c.Row, doneCol).Value) = 0 Then '未転記データのみ対象。
                myBook = c.Value & "　" & c.Offset(, 1).Value & ".xls" 'ブック名の生成
                If Len(Dir(myPath & myBook)) > 0 Then     'フォルダ内に存在する場合のみ処理
                    Workbooks.Open myPath & myBook
                    If Not IsObject(Evaluate(shName & "!A1")) Then   '念のためシートの存在チェック
                        MsgBox myBook & "には" & shName & "が存在しません"
                        ActiveWorkbook.Close False
                    Else
                        With ActiveWorkbook.Sheets(shName)
                            .Range("A" & .Rows.Count).End(xlUp).Offset(1).EntireRow.Value = _
                                                                            c.EntireRow.Value
                        End With
                        ActiveWorkbook.Close True
                        .Cells(c.Row, doneCol).Value = "済"
                    End If
                Else
                    MsgBox myBook & "が指定フォルダに存在しません"
                End If
            End If
        Next  '次のブックを。
    End With

    Set dBook = Nothing

    Application.ScreenUpdating = True
    MsgBox "処理が完了しました"

 End Sub

 こんな感じです

 アップした後ちょっといじってみたのですが
 標準モジュールに１，２，３とあり２番目にコードがありました
これを１に全部移したら正常に動きました
２，３は削除しています。
 なんでか。。。

 すいません、あと注番に抽出された文字が日付になってしまいます
せるの書式設定で文字列にしたのですが今度は５桁の数字になりました
11-01-12（例）というのをそのまま抽出するにはどのようにすればよいでしょうか
（せい）

 >標準モジュールに１，２，３とあり２番目にコードがありました
 >これを１に全部移したら正常に動きました
 >２，３は削除しています。
 >なんでか。。。

 その３つの標準モジュールにどんなプロシジャがあったのか見えないけど、プロシジャは、どのモジュールにあっても動く。
 しかも、同じ名前のプロシジャが複数のモジュールにあっても動く。
 ただし、動かす時に、ツール->マクロ->マクロ　で選んでいるとすれば、ダイアログでは
 Module1.Sample とか Module2.Sample と　複数出てきて、選ばれたものが実行される。
 これがボタンなんかに登録されていたとすると、登録した時点のプロシジャが動く。
 あとで、おなじ名前のプロシジャを別の標準モジュールに書いても、それは動かない。
 これは、マクロショートカット登録でも同じこと。

 >注番に抽出された文字が日付になってしまいます
 >せるの書式設定で文字列にしたのですが今度は５桁の数字になりました
 >11-01-12（例）というのをそのまま抽出するにはどのようにすればよいでしょうか

 ＶＢＡを離れて、新規のブックのシート（書式は標準で設定されている）に　11-01-12　を入力するとどうなるかな？
 2011/1/12 になっちゃうね。ところが 11-50-70 なんて入力だと、そのまま入る。
 これは、ＭＳいわく、【エクセルの親切かつ強力な入力支援機能】だと。
 入力されたものが【日付のようだぞ】と判断して、セルに格納する際に【勝手に日付型】にしてしまう。
 一方、11-50-70 だと 50月という月はないし、70日という日もないので、これはそのまま格納する。
 便利といえば便利だけど、おせっかいといえばおせっかい。

 >セルの書式設定で文字列にした

 これは、入力して 2011/1/12 に【なった後】に書式設定したんだよね。
 入力した時点で、この値は日付になってしまっている。
 で、ややこしくなるので割愛するけど、日付型の値の【正体】は【シリアル値】で小数点以上が
 （標準設定では）1900/1/1 から数えた累計の日数。なので 2011/1/12 は　40831。
 値がこうなってしまっているものを、文字列書式にしても、40831 が文字列となって、セルの左に寄せられるだけ。
 やるなら、値をいれる前に、その列に対して書式設定をしておく。
 あるいは、シート上で、入力時に　'11-01-12 と　頭にシングルクォーテーションをつけてやると
 自動変換されず、文字列として受け入れてくれるよね。なのでＶＢＡからも、頭に ' をつけてやるとＯＫ。

 今回のケースでは、行単位に一括して転記しているので、特定の列のデータの頭に ' を付けるというより
 あらかじめ、その列の書式を文字列にしておくのがいいと思う。
 すでに存在するブックに関しては、がんばって手作業で。
 シート追加のプロシジャで追加するものについては　連絡済の書式設定コードのあたりに
 Columns("A:A").NumberFormatLocal = "@" これを追加しておけばいいかな。

 (ぶらっと)

 いろいろと教えて頂き本当にありがとうございました
すべて思ったことがうまくいきました
詳しいところまで説明いただいて大変勉強になりました
ぶらっとさんに見て頂いてとてもわかりやすく親身になって
考えて頂きありがとうございました

 またこの場で質問させて頂くことがあるとおもいますが
そのときはまたよろしくお願いします

（せい）

コメント返信：

[ 一覧(最新更新順) ]

[[20110831092933]] 『エクセルでファイル名取得』（せい） ページの最後に飛ぶ

[[20110831092933]]　『エクセルでファイル名取得』（せい）　ページの最後に飛ぶ