vba 初心者

質問

いつもお世話様です。
vbaを始めたばっかりで、色々な情報をもらったのですが、
まだ理解に苦しんでいるところがあります。

Private Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)

Sub PrintPDF(ByVal FileName As String, _
Optional ByVal Copies As Long = 1)

Dim dtLimit As Date
Dim lngChannel As Long
Dim I As Long
Dim blnAlerts As Boolean

CreateObject("Wscript.Shell").Run "AcroRd32.exe", 7

dtLimit = Now() + TimeSerial(0, 0, 10) ' 起動待ちの制限時間
With Application
blnAlerts = .DisplayAlerts 'DisplayAlertsを元に戻す為に初期値を記憶
.DisplayAlerts = False
End With
On Error GoTo Err_Handler
lngChannel = DDEInitiate("Acroview", "Control")
On Error GoTo 0
Application.DisplayAlerts = blnAlerts

For I = 1 To Copies
DDEExecute lngChannel, _
"[FilePrintSilent(""" & FileName & """)]"
Next
DDEExecute lngChannel, "[AppExit]"
DDETerminate lngChannel
Exit Sub

Err_Handler:
If Now() < dtLimit Then
Sleep 200
Resume
End If
Application.DisplayAlerts = blnAlerts
Err.Raise Err.Number, , "Adobe Readerとの通信を開始できません"

End Sub

Dim searchNo As Variant
Dim searchCount As Integer
Dim Localpath As Variant
Dim MyFile As String
Dim strFindRange As String

Localpath = ThisWorkbook.Path

Do
searchNo = _
StrConv(InputBox("図番を入力してください"), vbNarrow + vbUpperCase) 'Strconv=大文字・半角
If searchNo = "EXIT" Then Exit Sub

Do
searchCount = _
WorksheetFunction.CountIf(ActiveSheet.Range("A:A"), searchNo)

Select Case searchCount　←(2)
Case 0
MsgBox "正しい番号を入力して下さい"
Exit Do '外側のループに移動
Case 1
strFindRange = _
ActiveSheet.Range("A:A"). _
Find(what:=searchNo, Lookat:=xlWhole).Address　←(4)
Case Else
MsgBox "同じ番号が複数登録されています"
Exit Do
End Select

MyFile = Localpath & "\" & searchNo & Range(strFindRange).Offset(0, 1) & ".pdf"

If Dir(MyFile) = "" Then
MsgBox MyFile & " が見つかりません" & vbCrLf _
& "実際にファイルが有るか確認して下さい"
Exit Do
End If

If MsgBox(Range(strFindRange).Offset(0, 1) _
& " を印刷しますか", vbOKCancel) = vbCancel Then
Exit Do
End If

PrintPDF (MyFile)
Exit Do
Loop
Loop
End Sub

(1)ここの部分で、空白かキャンセルボタンをしたら
StrConv(InputBox("図番を入力してください"), vbNarrow + vbUpperCase)に戻りたいのですが、この場合どこにexit do を入れたいか分かりません。
(2)データが入っているフォルダ内に複数あるならそれを分岐にする方法ってありませんか？
(3)ここのRange(strFindRange).Offset(0, 1) は必要があるのでしょうか？
(4)Find(what:=searchNo, Lookat:=xlWhole).Address　部分の意味がわからないのですが教えてください。
ご指導よろしくお願いします

回答No.5

ham_kamo · ベストアンサー

> 重複した図番が一覧にあった場合、別シートにファイル名一覧を
> 書き出す方法をやりたいです。

ではその方法でいきましょう。「重複データ」というシートに書き出すことにするので、その名前のシートを用意してください。

それで、そのシートに書き出してもまた入力画面に戻ると、END（EXITから変えたみたいですね）でいったんマクロを終了して、重複データのシートを確認する、という作業になると思うので、それなら図番が重複したときは、そのままそのシートを表示して、マクロをそこで終了した方が使い勝手がいいかもしれません。

一応、そのように手を加えてみました。

まず、元々のマクロの

Case Else
MsgBox "同じ番号が複数登録されています"
Exit Do

だった部分を、No.2の回答でも修正していますが、

Case Else
ListFiles (searchNo)
Exit Sub

に変更してください。なお、図番が重複しても、終了せずにそのまま入力画面に戻るのであれば、
Exit Sub
は
Exit Do
のままでかまいません。

さらにNo.2で追加した ListFiles プロシージャを下記の内容に入れ替えてみてください。

Sub ListFiles(No As Integer)
　Dim WS As Worksheet
　Dim i As Integer
　Set WS = Worksheets("重複データ") 'リストするシート名
　WS.Cells.ClearContents

　i = 1
　Dim FName As String
　FName = Dir(ThisWorkbook.Path & "\" & No & "*")
　Do While FName <> ""
　　WS.Cells(i, 1).Value = FName
　　i = i + 1
　　FName = Dir()
　Loop
　WS.Activate
　MsgBox "同じ番号が複数登録されています"
End Sub

お礼

pcの調子が悪くて返事送れてすいません。
ありがとうございました！
参考になりました。

回答No.4

ham_kamo

プロシージャを挿入する場所はそこでいいのですが、シート名が一箇所違っています。

ActiveSheetを Worksheets("検索データ") に変更したようなので、アクティブシートに拘る必要はなくなったのですが、追加したプロシージャの冒頭にある、

Set WS = Worksheets("検索データ") 'リストするシート名

これは、重複したファイル名一覧を書き出すシート名にするつもりだったので、このマクロの場合だと、他のシート名にしてください。

ですが、そもそも重複した図番が一覧にあった場合、別シートにファイル名一覧を書き出すのか、他のシートに転記したいのかを確認せずにマクロを作ってしまいました。
ご希望通りにマクロに修正を入れようと思うので、図番が重複した場合、どこにファイル名一覧を書き出せばよいか教えてください。
「検索データ」シートのC列とかD列が空いていたらそこに、とか、「○○」という別のシートに、というように具体的にお願いできますか？

それて、最初に補足をお願いしたらよかったのですが、このプロシージャでは、No.1の補足にある、

> (2)Dir関数で呼び出したファイル名をシートに全て表示して,それをカウントしたい

を満たしていません。これも含めて修正しようと思うのですが、図番の規則はどうなっているのでしょうか。たとえば30で検索して複数見つかった場合、
30xxx.pdf
300yyy.pdf
のように先頭が30でなく300のようなファイル名も一覧に出てきてしまいます。図番の桁数が全て同じならこのようなことは起こらないのですが、図番の桁数などには決まりがあるのでしょうか。

以上、補足をお願いします。

補足

お世話様です。
>Set WS = Worksheets("検索データ") 'リストするシート名は
Set WS = Worksheets("sheet1") にすればよいのでしょうか？
>そもそも重複した図番が一覧にあった場合、別シートにファイル名一覧を書き出すのか、他のシートに転記したいのかを確認せずにマクロを作ってしまいました
なのですが重複した図番が一覧にあった場合、別シートにファイル名一覧を書き出す方法をやりたいです。
なにか他にいいアイディアがあったら教えてください！

>図番の桁数などの決まりで、
たとえば・・・cxx001a001
とかcxx001aa01
とか使っています。

よろしくお願いします。

回答No.3

ham_kamo

まずは疑問点から。

> searchCount = 0 と　searchCount = _
> があるのですがこれは2つ定義してあるのですが2つあっても
> いいのでしょうか？

これは、If文によって処理が分岐しているので、同時に実行されることはありません。
このIf文を日本語に訳すと、

If searchNo = "" Then　（searchNoが空、つまり何も入力せずにOKを押したか、キャンセルを押した場合は、）
　searchCount = 0 （searchCountの値を０にする）
Else　（それ以外の場合は）
　searchCount = _
　WorksheetFunction.CountIf(ActiveSheet.Range("A:A"), searchNo)
　（searchNoの値をA列から検索して、その数をsearchCountに代入する）
End If

という感じになっています。

> (2)ってどこの部分に追加すればよろしいのでしょうか？すいません理解不足で・・・

すみません、説明不足でしたね。質問文のマクロの一番最後、End Sub の下に追加してください。

補足

(1)分かりやすい説明ありがとうございました！

(2)なのですが、実はsheet1にフォームのボタン(検索ボタン)を作り、sheet2に検索データを入れるのを作ってみたのですが、この場合(2)のdir関数を使った場合は
Sub PDF_Menu()
Dim searchNo As Variant
Dim searchCount As Integer
Dim Localpath As Variant
Dim MyFile As String
Dim strFindRange As String

Localpath = ThisWorkbook.Path

Do
searchNo = _
StrConv(InputBox("図番を入力してください"), vbNarrow + vbUpperCase)
If searchNo = "END" Then Exit Sub
'Exit Do
Do
If searchNo = "" Then
searchCount = 0
Else
searchCount = _
WorksheetFunction.CountIf(Worksheets("検索データ").Range("A:A"), searchNo)
End If

Select Case searchCount
Case 0
MsgBox "正しい番号を入力して下さい"
Exit Do '外側のループに移動
Case 1
strFindRange = _
Worksheets("検索データ").Range("A:A"). _
Find(What:=searchNo, lookAt:=xlWhole).Address
Case Else
MsgBox "同じ番号が複数登録されています"
Exit Do
End Select

MyFile = Localpath & "\" & searchNo & Range(strFindRange) & ".pdf"

If Dir(MyFile) = "" Then
MsgBox MyFile & " が見つかりません" & vbCrLf _
& "実際にファイルが有るか確認して下さい"
Exit Do
End If

If MsgBox(Range(strFindRange) _
& " を印刷しますか", vbOKCancel) = vbCancel Then
Exit Do
End If

PrintPDF (MyFile)
Exit Do
Loop
Loop
End Sub
Sub ListFiles(No As Integer)
Dim WS As Worksheet
Set WS = Worksheets("検索データ") 'リストするシート名
WS.Cells.ClearContents

Dim F As Range, R As Range
Dim i As Integer
Dim FName As String

Set R = WS.Range("A1")
Set F = Worksheets("検索データ").Range("A:A").Find(What:=No, lookAt:=xlWhole)
i = 0
Do While F.Row > i
FName = F.Value & F.Offset(0, 1).Value & ".pdf"
R.Value = FName
If Dir(ThisWorkbook.Path & "\" & FName) = "" Then
R.Offset(0, 1) = "ファイルなし"
End If
Set R = R.Offset(1)
i = F.Row
Set F = Worksheets("検索データ").Range("A:A").FindNext(After:=F)
Loop
MsgBox "同じ番号が複数登録されています" & vbCrLf & _
WS.Name & "にファイル名一覧を転記しました。"
End Sub
でよろしいのでしょうか？
よろしくお願いします。

回答No.2

ham_kamo

No.1です。所用でPCがしばらく開けない状態だったため、回答が遅れてしまいました。もう解決していたらすみません。

まず(1)ですが、私の環境で試したところ、Inputboxに空白もしくはキャンセルボタンを押した場合は、
MsgBox "正しい番号を入力して下さい"
が表示され、InputBoxに戻りました。何がいけないんでしょうね？

原因がわからないので、とりあえず

searchCount = _
WorksheetFunction.CountIf(ActiveSheet.Range("A:A"), searchNo)

の部分を、

If searchNo = "" Then
　searchCount = 0
Else
　searchCount = _
　WorksheetFunction.CountIf(ActiveSheet.Range("A:A"), searchNo)
End If

にしてみてはいかがでしょうか。

(2)ですが、
> Dir関数で呼び出したファイル名をシートに全て表示して,それをカウントしたい

ということですが、これは別のシートに表示してカウントし、PDFファイルのプリントまで行わない、ということでしょうか。

Dir関数を用いて、Dir(SearchNo & "*.pdf")とファイルを検索するようにもできるのですが、図番が30の場合、300xxx.pdfというファイルもマッチしてしまいます。図番の採番規則がわからないので、A列の図番とB列の図名からファイル名を作り出し、それをSheet2に書き出すようなサンプルを作ってみました。
セル内容からファイル名を作りだし、そのファイルが実際にない場合には「ファイルなし」とB列に表示するようにしています。
Select Case内の
MsgBox "同じ番号が複数登録されています"
の行をコメントアウトして、
ListFiles (searchNo)
という行を挿入し、以下のプロシージャを追加してください。

Sub ListFiles(No As Integer)
　Dim WS As Worksheet
　Set WS = Worksheets("Sheet2") 'リストするシート名
　WS.Cells.ClearContents

　Dim F As Range, R As Range
　Dim i As Integer
　Dim FName As String

　Set R = WS.Range("A1")
　Set F = ActiveSheet.Range("A:A").Find(What:=No, lookAt:=xlWhole)
　i = 0
　Do While F.Row > i
　　FName = F.Value & F.Offset(0, 1).Value & ".pdf"
　　　R.Value = FName
　　If Dir(ThisWorkbook.Path & "\" & FName) = "" Then
　　　R.Offset(0, 1) = "ファイルなし"
　　End If
　　Set R = R.Offset(1)
　　i = F.Row
　　Set F = ActiveSheet.Range("A:A").FindNext(After:=F)
　Loop
　MsgBox "同じ番号が複数登録されています" & vbCrLf & _
　WS.Name & "にファイル名一覧を転記しました。"
End Sub

ただし、このサンプルはSheet2にファイル名を書き出しますが、Sheet2をアクティブにはしません。番号を入力するプロシージャで ActiveSheet で図番を検索したりしているので、ActiveSheet を他のシートに変えてから InputBox に戻ると、その後誤作動してしまいます。（したがって、Sheet2を確認するには exit してシートを切り替える必要があります）

(3)ですが、

> Msgboxの"を印刷しますか"と表示しかでないのですが、
> (strFindRange).Offset(0, 1)の部分っているのかなと思いました。

Ｂ列には図番に対応する名前が入っていますか？このソースを見る限り、Ａ列に図番、Ｂ列に図名が入っており、図番で検索したら、それに対応する図名を取りだしてファイル名にしています。その図名に相当する部分が、

Range(strFindRange).Offset(0, 1)

です。私が実際にダミーのデータを入れて実行したところ、
「ＡＢＣを印刷しますか」
と出てきます。
もしＡ列の値（図番）で「○○を印刷しますか」と出すのであれば、 .Offset(0, 1) の部分は不要です。

補足

お世話様です。
(1)なのですが、初歩的な質問ですいません。
searchCount = 0 と　searchCount = _
があるのですがこれは2つ定義してあるのですが2つあってもいいのでしょうか？すいませんがよろしくお願いします。
If searchNo = "" Then
　searchCount = 0
Else
　searchCount = _
　WorksheetFunction.CountIf(ActiveSheet.Range("A:A"), searchNo)
End If
にしたところInputboxに空白もしくはキャンセルボタンを押した場合は、
MsgBox "正しい番号を入力して下さい"になりました！ありがとうございます。
(2)ってどこの部分に追加すればよろしいのでしょうか？すいません理解不足で・・・
(3)なのですが、A列だけで検索するので.Offset(0, 1)はいらないですね・・・ありがとうございました！

回答No.1

ham_kamo

見たところ、シートのA列に図番が入っており、B列にそれに対応する図の名前が入っていて、図番を入力すればPDFファイルが自動的にAdobe Readerを起動して印刷するマクロと見受けました。

それで、質問文では２番目のプロシージャの最初の方が切れていると思うのですが。

> (1)ここの部分で、空白かキャンセルボタンをしたら
の(1)がありません。どの部分のことでしょうか。

> (2)データが入っているフォルダ内に複数あるならそれを分岐にする方法ってありませんか？

それを分岐にする、というのは具体的にどういうことなのでしょうか。分岐する、というのはIf文やSelect Case文などで条件判断をすることだと思うのですが、どういう条件で分岐して、どういう処理をしたいのでしょうか。

以上(1)(2)について補足をお願いします。

順序が前後しますが、(4)についてです。

> (4)Find(what:=searchNo, Lookat:=xlWhole).Address

FindはRangeオブジェクトで検索を行うメソッドです。名前つき引数の What は検索する文字列を指定し、Lookatは部分一致(xlPart)か完全一致(xlWhole)かを指定します。この場合図番がＡ列の値と完全一致するものを検索しているので、xlWholeを指定しています。

AddressはRangeオブジェクトのプロパティで、そのオブジェクトが指す領域のセル番地を返します。

わからないときはVBAのヘルプで検索すると、ヘルプに書いているので、まずはヘルプで調べる癖をつけた方がいいですよ。

それで、この場合２つ前の行から続いていて、つなげると

strFindRange = ActiveSheet.Range("A:A").Find(what:=searchNo, Lookat:=xlWhole).Address

となります。
ActiveSheetのRange("A:A")（Ａ列）から、SearchNo（図番）を検索し、見つかったセルのアドレスを strFindRange に代入する、という意味になります。

> (3)ここのRange(strFindRange).Offset(0, 1) は必要があるのでしょうか？
これも「ここの」に相当する(3)が見あたりませんが、

MyFile = Localpath & "\" & searchNo & Range(strFindRange).Offset(0, 1) & ".pdf"

のことでしょうか。

strFindRangeは、(4)で解説した通り「A列で図番を検索して見つかったセル番地」が入っています。
これはあくまでも図番のアドレスなのでＡ列です。その右隣のＢ列に図名が入っているので、Offset(0,1)で１つ右のアドレスを参照して図名を取りだし、図番＋図名.pdf　というファイル名を作成しています。

If MsgBox(Range(strFindRange).Offset(0, 1) _
& " を印刷しますか", vbOKCancel) = vbCancel Then

の箇所のことを言っているのなら、上記の説明と同じことで、
「○○を印刷しますか」
というダイアログの○○のところに図番でなく図名が入るようにＢ列を参照している、ということです。

補足

補足遅くなってすいません。
(1)はsearchNo = _
StrConv(InputBox("図番を入力してください"), vbNarrow + vbUpperCase)です。
もしInputboxに空白もしくはキャンセルボタンを押した場合は
Case 0
MsgBox "正しい番号を入力して下さい"
Exit Do
の部分に行くはずなのですが
searchCount = _
WorksheetFunction.CountIf(ActiveSheet.Range("A:A"), searchNo)
の部分でデバックがでてしまいます。どうしてでしょうか？
(2)Dir関数で呼び出したファイル名をシートに全て表示して,それをカウントしたいのですが、dir関数(ヘルプを使ったり調べたりしましたが)よくわかりません。
(3)はIf MsgBox(Range(strFindRange).Offset(0, 1) _
& " を印刷しますか", vbOKCancel) = vbCancel Then
の部分ですが、Msgboxの"を印刷しますか"と表示しかでないのですが、
(strFindRange).Offset(0, 1)の部分っているのかなと思いました。
よろしくお願いします。