[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『デスクトップフォルダ内EXCELファイルから文字取得』（たんたん）
はじめまして。
VBA触り始めた者ですが、ちょっと高度でどう作成していいのか、
分かりません。
どうかご教授よろしくお願いします。
希望の動き
1.デスクトップフォルダにあるEXCELファイルを開く
2.そのシート内に特定文字があればそれの1つ右のセル内の文字を
sheet1へ書き出す
というものです。
デスクトップ上のフォルダ名:発注依頼書
EXCEL:複数ある場合あり
特定文字:材料手配
特定文字はセルA10にあり、取得したい文字はその横(結合しているのでH10)
にあります。
可能であればsheet1への書き出しは･･･
A列･･･取得したEXCELファイル名
B列･･･取得したい文字
に書き出せれば、と思っております。
過去記事:20170116220914が近いと思われますが、
どこをどう改良すればいいのか･･･。
分かっていない状態で、ここに書いていますが、
どうぞよろしくお願いします。
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
(1) デスクトップにある「発注依頼書」というフォルダの中にある
(2)「●●.xls?」を片っ端から開いて
(3)【シートが不明】のA10セルが「材料手配」となっていたら
(4)【シートが不明】のH10セルをコピーして
(5)「マクロを記述したブック」の「Sheet1」のうち
A列・・・・・(4)を貼り付け
B列・・・・・(2)で開いたブック名を記入
C列・・・・・【シートが不明】のシート名を記入
(6)開いたブックを閉じる
(7)(1)のフォルダ内にある、「●●.xls?」全部で(2)～(6)を繰り返す
＞VBA触り始めた者
とのことですから、一足飛びにやろうとしても混乱するように思いますので、
（A）特定のフォルダにある「●●.xls?」を全部探す方法 （B）（あらかじめ開いておいた）ブックの各シートを巡回し、A10セルの値を取得（チェック）する方法 （C）ブック間でコピー＆ペーストをする方法 (D)ブックを開く方法、閉じる方法
というように部品で考えてから、これらを合体する手順で調べてみてはどうでしょうか。
(A)のヒント http://officetanaka.net/excel/vba/tips/tips107.htm http://officetanaka.net/excel/vba/file/file07.htm
(B)のヒント https://www.vba-ie.net/statement/foreachnext.php https://programming-study.com/technology/vba-for-each/
(C)のヒント http://officetanaka.net/excel/vba/cell/cell09.htm
(D)のヒント http://officetanaka.net/excel/vba/file/file01.htm http://officetanaka.net/excel/vba/file/file03.htm
（もこな２） 2019/02/25(月) 12:56
とりあえず、参考用。
Sub test()
Dim wk As Worksheet
Dim cFiles As Variant
Dim cPath As String
Dim iR As Long
Dim iw As Long
Dim i As Long
Application.ScreenUpdating = False
Set wk = Sheets("Sheet1")
wk.Cells.ClearContents
cPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\発注依頼書\"
cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A:-D/B/S """ & cPath & "*.xls*""").StdOut().ReadAll(), vbNewLine)
For i = 0 To UBound(cFiles) - 1
If InStr(cFiles(i), "$") = 0 Then
With Workbooks.Open(cFiles(i), False, True)
With .Sheets(1)
If .Range("A10") = "材料手配" Then
iw = InStrRev(cFiles(i), "\")
iR = iR + 1
wk.Cells(iR, "A").Value = Mid(cFiles(i), iw + 1)
wk.Cells(iR, "B").Value = .Range("H10")
End If
End With
.Close False
End With
End If
Next i
Application.ScreenUpdating = True
End Sub
（???） 2019/02/25(月) 15:02
参考のヒントありがとうございます。
まだヒントをほぼコピーで持ってきてどんなんか試し中です。
Sub test1()
Dim buf As String, cnt As Long
Const Path As String = "C:\Users\test\Desktop\発注依頼書\"
buf = Dir(Path & "*.xlsx")
Do While buf <> ""
cnt = cnt + 1
Cells(cnt, 1) = buf
buf = Dir()
Dim MyR As Range 'オブジェクト変数にRangeを指定'
Range("A20").Select
For Each MyR In Selection 'Selection内のセルを操作対象とする'
Worksheets("Sheet1").Range("H10").Copy Worksheets("Sheet2").Range("H10")
Next MyR
Loop
MsgBox ("終了")
End Sub
まだ全然動けていません。
ファイル名取得で少し喜んでいる段階･･･。レベルがバレてしまう＞＜
まだまだ。
（たんたん） 2019/02/25(月) 15:35
大変遅くなり、申し訳ございません。
???さんのコードで動き、そのデータの流れを追っているところです。
VBAにコマンドを組み合わせており･･･思いつかないどころか、
こんなこともできるのか！と。
これで動きはできると思った中、もう1つ要件課題を言われ、
思いつくコードを追記しました。(***↓↓↓以降)
Sub test()
Dim wk As Worksheet
Dim cFiles As Variant
Dim cPath As String
Dim iR As Long
Dim iw As Long
Dim i As Long
Dim d1 As String
Dim dt1 As Date
Dim dt2 As Date
Application.ScreenUpdating = False
Set wk = Sheets("Sheet1")
wk.Cells.ClearContents
cPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\発注依頼書\"
cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A:-D/B/S """ & cPath & "*.xls*""").StdOut().ReadAll(), vbNewLine)
For i = 0 To UBound(cFiles) - 1
If InStr(cFiles(i), "$") = 0 Then
With Workbooks.Open(cFiles(i), False, True)
With .Sheets(1)
If .Range("A10") = "材料手配" Then'資材･建材在庫確認FLG
iw = InStrRev(cFiles(i), "\")
iR = iR + 1
wk.Cells(iR, "A").Value = Mid(cFiles(i), iw + 1)
wk.Cells(iR, "B").Value = .Range("H10")
End If
End With
'*** ↓↓↓
d1 = .Range("I1") '格納資料の作成日付と当日以降の日付チェック(デグレ防止)
dt1 = CDate(Format(d1, "yyyy/mm/dd")) dt2 = Date '当日日付
If dt1 >= dt2 Then wk.Cells(5, 3).Value = dt1
Debug.Print "OK"
.PrintOut
'.Close False
wk.PrintOut
Else
MsgBox ("日付がおかしいファイル有り！"), vbCritical
End If
End With
.Close False
End With
End If
Next i
Application.ScreenUpdating = True
End Sub
当日より古い(過去)発注書は仮に発注依頼書フォルダに入っていても
印刷しないようにしたかったのですが、分からず。
分かる範囲で調べて過去日付があれば、メッセージを出すようにしました。
が、これでいくと過去の発注書は印刷しませんが、
当日より新しい発注書は印刷されてしまいます。
今はそのメッセージが出力すれば、発注依頼書フォルダ内を確認し、
不要分を取り除き、再度実行するように報知しています。
できれば、過去の発注書が入っていた場合は読み飛ばす
当日以降未来分のみを印刷するようにって可能でしょうか？
頼り切りで申し訳ございませんが、再度ご教授お願いできますでしょうか。
（たんたん） 2019/03/01(金) 19:07
また、手入力された日付を使う方法以外に、ファイルの更新日時を使う方法と、ブックの最終保存日時を使う方法があります。 手入力だと入力忘れがあったりしないでしょうか？
（???） 2019/03/04(月) 09:04
ご回答、ありがとうございます。
＞d1が作成日付だとすると、d1とd2の大小関係判定が逆ではないですか？
テストを行っているのですが、特にこれで大丈夫と思っています。
d1が作成日付(どうやら請求予定日らしい)
d2が当日日付 であるので
If dt1 >= dt2 Thenであり、当日以降未来分が出力OKとしたいので
2/28 3/4 の場合は出力NG
3/5 3/5 の場合は出力OK
となります。
＞（d1の代入時、.Sheets(1)のWithが終わっているので、エラーになりそうですが？）
発注依頼書フォルダ内に作成日付が2/28,3/4,3/5の3シートがあったとします。
これで実行した場合、
2/28,3/1作成日付分はNGのメッセージ出力し印刷はされませんが、
3/5作成日付分のデータは印刷されてしまいます。
Exit Subで抜ければいいのでしょうが、既に印刷がかかったものは印刷されてしまいます。
しかし、運用を考えるとNGがなければ印刷するの方がという声が出そうと懸念しています。
ただし、それにはどうすればというのが知識不足で分かりません。
よって今は過去請求予定日分(2/28,3/1分)を取り除いて再処理かけると展開しようとしています。
＞手入力だと入力忘れがあったりしないでしょうか？
d1に作成日付が入りますがここは経理部が入力しています。
ファイル更新日時/ブック保存日時でもと思いましたが、
実際は経理担当がコントロールしており、一概にファイル更新日時 = 作成日付
ではないようです。
（たんたん） 2019/03/05(火) 09:26
初心者的発想かもしれませんが･･･
1.まずは発注依頼書フォルダ内の各ブックを開いて日付チェック
2.請求日付的に問題なければ、教えていただいているコードで印刷
と2段階しか思いつきませんでした。
その上で～
Sub test()
Dim wk As Worksheet
Dim cFiles As Variant
Dim cPath As String
Dim iR As Long
Dim iw As Long
Dim i As Long
Dim d1 As String
Dim dt1 As Date
Dim dt2 As Date
Application.ScreenUpdating = False
Set wk = Sheets("Sheet1")
wk.Cells.ClearContents
cPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\発注依頼書\"
cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A:-D/B/S """ & cPath & "*.xls*""").StdOut().ReadAll(), vbNewLine)
'***お試し
Do While i < UBound(cFiles) - 1
If InStr(cFiles(i), "$") = 0 Then
With Workbooks.Open(cFiles(i), False, True)
With .Sheets(1)
d1 = .Range("H10") '発注依頼書の請求日付
dt1 = CDate(Format(d1, "yyyy/mm/dd"))
dt2 = Date '当日日付
If dt1 < dt2 Then MsgBox ("日付がおかしいファイル有り！"), vbCritical
End With
.Close False
End With
End If
'Next i
i = i + 1
Loop
i = 0
'***お試し終了
For i = 0 To UBound(cFiles) - 1
If InStr(cFiles(i), "$") = 0 Then
With Workbooks.Open(cFiles(i), False, True)
With .Sheets(1)
If .Range("A10") = "材料手配" Then'資材･建材在庫確認FLG
iw = InStrRev(cFiles(i), "\")
iR = iR + 1
wk.Cells(iR, "A").Value = Mid(cFiles(i), iw + 1)
wk.Cells(iR, "B").Value = .Range("H10")
End If
End With
'*** ↓↓↓
d1 = .Range("I1") '格納資料の作成日付と当日以降の日付チェック(デグレ防止)
dt1 = CDate(Format(d1, "yyyy/mm/dd")) dt2 = Date '当日日付
If dt1 >= dt2 Then wk.Cells(5, 3).Value = dt1
Debug.Print "OK"
.PrintOut
'.Close False
wk.PrintOut
Else
MsgBox ("日付がおかしいファイル有り！"), vbCritical '←ここがいるかどうか
End If
End With
.Close False
End With
End If
Next i
Application.ScreenUpdating = True
End Sub
有識者から見ると、コードが汚いかもしれませんが
どうでしょうか？(逆質問ですいません)
（たんたん） 2019/03/05(火) 12:29
＜修正＞
修正前:Do While i < UBound(cFiles) - 1
修正後;Do While i < UBound(cFiles)
＜追記＞
Do While～Loop内でNGがあれば処理を終わらせたいのですが、ここが分かりません。
(NGがあれば全てを印刷させないようにしたいため)
Loop抜けた直後にEndとするとそこで処理が終了してしまいますし･･･。
何かいい方法ありますでしょうか？
（たんたん） 2019/03/05(火) 12:49
・段付けが変。そのせいか、With文がひとつ多くないですか？ これ、動きますか？（回答者にデバッグさせないように） ネストが汚いソースは、人に見せてはいけません。 ・ForループとWhileループ。やっていることは同じなのに、2つの命令を使うのは変。 Whileループはミスすると無限ループする可能性があるので、この場合はForループに統一すべき。 （それとも、Whileループを使わなければいけなかった理由があるのですか？） ・「お試し」部分で日付不正があるとMsgBox表示しますが、その後、そのまま印刷処理に流れるので、メッセージの意味なし。 そもそも、このメッセージを見ても、どのファイルが不正だったのか判断できない。 （不正を見つけたら中断ならば、ブックをClose後、Exit Subすれば良いですが、複数のブックに日付不正がある可能性は無いのですか？）
改善案。
・日付判定だけでループさせず、「材料手配」判定と日付の抜き出しをまとめれば１つのループになるでしょう。 ・日付情報と判定結果はMsgBox表示せず、C列以降にセットして最後までループを通す。そうすれば、一覧の中に判定結果が表示されるので、 複数不正ファイルがあってもいちいち中断せず、1回で判るでしょう。 ・このプロシジャではPrintOutは行わず、作成した一覧を元にループし、判定OKなものだけ全部印刷する別プロシジャを作成した方が、 運用が楽になりませんか？ （???） 2019/03/05(火) 13:26
色々ご指摘、ありがとうございます。
段付けについては今から修正します。
確かにどことどこをくくっているのか、迷いますね。
とりあえず、まずは動かすこと！という意識があるようでした。
For/Whileについてはあまり意識はしていませんでした。
自分の思いと検索でやりたい事でWhileが出てきて･･･。
無限ループまで意識していませんでした。ちょっと危なかったです。
日付不正時のMSG出力後について、フォルダ内全て確認し
本当はそこで終了させたいのですが･･･
全然分かっていないんで、今はエラーMSG出力させて処理を止めてしまう方向で。
エラーのあったファイル名は
If dt1 < dt2 Then MsgBox ("日付がおかしいファイル有り！" & vbLf & cFiles(i) & vbLf), vbCritical
これでファイル名は表示させようと思っています。
＞（不正を見つけたら中断ならば、ブックをClose後、Exit Subすれば良いですが、
＞複数のブックに日付不正がある可能性は無いのですか？）
そうですね、まさに複数ファイルあることが多いので、なかなか上手くいっていません。
（たんたん） 2019/03/05(火) 17:49
余談ながら、While文が危ないよ～、というのは、今回はループ内で i = i + 1 としてますよね。 例えばこの行を間違えて消してしまったりとか、プラストマイナスを間違えたとかすると、いつまでたっても抜ける条件が成立せず、無限ループに陥る訳です。
間違えなければ問題ないですし、心配ならループの内側にDoEventsを1行入れておけば、マクロを停止することができます。 Forループの場合、ループ回数に到達すれば抜けるので、ミスしても全然処理しないか、最後までループするかになるので、安全なのですよ。
また、テキストファイルを1行ずつ読み込む場合のように、何行あるか途中では判断できないような場合にはWhile文が有効なので、使いどころを考えましょう。
（???） 2019/03/05(火) 18:18
何度もありがとうございます。
改善案については、まだまだ勉強とテストを繰り返さないと
理解できるには程遠く、もう少しお時間いただきます。
分かっていない中でのWhile文の無限ループに入ったときには
落ち着いて「Ctrl＋Pause」を押す事、覚えておきます。
今は動く！で喜んでいますが、次は使いどころを見極めて使えるよう
がんばります。
(内容に対する返信にはなってないかも･･･)
（たんたん） 2019/03/05(火) 19:38
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.