- ベストアンサー
VBA初心者が困っているところ
ham_kamoの回答
- ham_kamo
- ベストアンサー率55% (659/1197)
見たところ、シートの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 の箇所のことを言っているのなら、上記の説明と同じことで、 「○○を印刷しますか」 というダイアログの○○のところに図番でなく図名が入るようにＢ列を参照している、ということです。
関連するQ&A
- vba 初心者
Dim a As Integer Dim inbox As String Dim Localpath As Variant Dim c As Range, myFadd As String Dim flag As Variant Dim MyShell As Object Dim Mysh As String Dim newHour As Variant Dim newMinute As Variant Dim newSecond As Variant Dim waitTime As Variant Localpath = ThisWorkbook.Path a = 1 inbox = InputBox("番号") Do If inbox = Empty Then Exit Sub End If If inbox = Cells(a, 1) Then MsgBox ("あります") Exit Do Else a = a + 1 ElseIf Cells(a, 1) <> inbox Then MsgBox ("ない") End If Loop Set MyShell = CreateObject("WScript.Shell") MyShell.Run ("AcroRd32.exe /n") MyShell.Run ("AcroRd32.exe /p") & Localpath & "\" & Myfile & ".pdf" newHour = Hour(Now()) newMinute = Minute(Now()) newSecond = Second(Now()) + 10 waitTime = TimeSerial(newHour, newMinute, newSecond) Application.Wait waitTime Application.SendKeys "{Enter}", True '次の使用例は、10 秒を過ぎるとメッセージを表示します。 If Application.Wait(Now + TimeValue("0:00:10")) Then MsgBox "時間が過ぎました。" End If End Sub ExcelからPDFファイルを検索して印刷したいのですが、 見よう見まねで作ってみたもののエラーが出てしまってよく分かりません。 指摘できるところご指導よろしくお願いします。
- 締切済み
- Visual Basic
- vba初心者
いつもお世話様です。 A列にあらかじめデータを入れといてinboxでデータを検索してもしあったらPDFファイルを開いて印刷でもしデータがなかったらinboxに戻るかたちにしたいんですけど、do...loopの使い方が分からないのと、デバックがでてしまってどう直せばいいかわかりません。サンプルコードがあれば助かります。よろしくお願いします。 Dim a As Integer Dim inbox As String Dim Localpath As Variant Dim c As Range, myFadd As String Dim flag As Variant Dim MyShell As Object Dim Mysh As String Dim newHour As Variant Dim newMinute As Variant Dim newSecond As Variant Dim waitTime As Variant Localpath = ThisWorkbook.Path a = 1 inbox = InputBox("番号") Do If inbox = Empty Then Exit Sub End If If inbox = Cells(a, 1) Then MsgBox ("あります") Exit Do Else a = a + 1 ←ここでデバックがでてしまいます。 ElseIf Cells(a, 1) <> inbox Then MsgBox ("ない") End If Loop Set MyShell = CreateObject("WScript.Shell") MyShell.Run ("AcroRd32.exe /n") MyShell.Run ("AcroRd32.exe /p") & Localpath & "\" & Myfile & ".pdf" newHour = Hour(Now()) newMinute = Minute(Now()) newSecond = Second(Now()) + 10 waitTime = TimeSerial(newHour, newMinute, newSecond) Application.Wait waitTime Application.SendKeys "{Enter}", True '次の使用例は、10 秒を過ぎるとメッセージを表示します。 If Application.Wait(Now + TimeValue("0:00:10")) Then MsgBox "時間が過ぎました。" End If End Sub
- ベストアンサー
- Visual Basic
- Application.DisplayAlerts =Falseでも警告される？
下記のコードを実行するとSheet1という名前のシートがないBookを開いた場合、「統合元ファイル○○のSheet1を開けません」という警告がでます。 無ければ集計しなくていいので「はい」を押せばいいのですが、その都度止まってしまうのは困ります。 Application.DisplayAlerts = False としても警告されるのはなぜでしょうか？出ないようにすることは出来ないのでしょうか？ Sub test03() 'Sheet1のみ開かずに統合 Dim MyFile As String, MyPath As String Dim SumFile() As Variant, i As Long MyPath = ThisWorkbook.Path & "\" MyFile = Dir(MyPath & "*.xls", vbNormal) Do Until MyFile = "" If MyFile <> ThisWorkbook.Name Then ReDim Preserve SumFile(i) Application.DisplayAlerts = False SumFile(i) = "'" & MyPath & "[" & MyFile & "]Sheet1'!R1C1:R10C2" 'A1からB10のLinkを変数に代入 Application.DisplayAlerts = True i = i + 1 End If MyFile = Dir Loop If i = 0 Then MsgBox "データが有りません （￣□￣；）！！": Exit Sub Worksheets("Sheet1").Range("A1").Consolidate Sources:=SumFile() End Sub
- ベストアンサー
- オフィス系ソフト
- マクロFind検索で見つからなかった時の対処
エクセル2013です 以下のコードを作成しましたが .Rowが色で塗られ 「型が違います」でERRになります。 .Columnの方はERRでなく なぜ.Rowの方がERRなのでしょうか？ よろしくお願いします。 Dim 検索行番号 As Range Dim 判定列番号 As Range Dim 検索列番号1 As Range Dim 検索列番号2 As Range Set 検索行番号 = Rows(1).Find("みかん").Column If 検索行番号 Is Nothing Then MsgBox "みかんが有りません。" End If Exit Sub Set 判定列番号 = Rows(1).Find("りんご").Column If 判定列番号 Is Nothing Then MsgBox "りんごが有りません。" End If Exit Sub Set 検索列番号1 = Range("B:B").Find("大箱").Row If 検索列番号1 Is Nothing Then MsgBox "大箱が有りません。" End If Exit Sub Set 検索列番号2 = Range("B:B").Find("小箱").Row If 検索列番号2 Is Nothing Then MsgBox "小箱が有りません。" End If Exit Sub
- ベストアンサー
- Excel（エクセル）
- Excel vba 一度で全角・半角の文字を検索
Excel vbaの初心者ですが、他のサイトを参考にして 以下のプログラムを作成しました。 指定された文字をシートから削除する物です。 「FindDelete」の中で、一度で全角・半角の文字を検索する方法があれば 教えてください。よろしくお願いします。 Sub FindDelete(ss As String) Dim FoundCell As Range Dim FirstCell As Range Dim Target As Range Dim c As Range Dim findArea As Range Set findArea = Intersect(Columns("E:F"), ActiveSheet.UsedRange) Set FoundCell = findArea.Find(What:=ss, LookAt:=xlPart) If FoundCell Is Nothing Then MsgBox ss & "は見つかりません" Exit Sub Else Set FirstCell = FoundCell Set Target = FoundCell End If Do Set FoundCell = findArea.FindNext(FoundCell) If FoundCell.Address = FirstCell.Address Then Exit Do Else Set Target = Union(Target, FoundCell) End If Loop Target.Select If MsgBox(ss & "：" & vbCrLf & Target.Count & "件見つかりました", vbYesNo, "削除しますか？") = vbYes Then For Each c In Target c = Replace(c, ss, "") Next c End If End Sub Sub tFindDelete() Dim ss As String ss = "カブシキガイシャ" ss = StrConv(ss, vbNarrow) FindDelete (ss) ss = StrConv(ss, vbWide) FindDelete (ss) ss = "ユウゲンガイシャ" ss = StrConv(ss, vbNarrow) FindDelete (ss) ss = StrConv(ss, vbWide) FindDelete (ss) End Sub
- 締切済み
- その他（プログラミング・開発）
- VBAで教えてください。
データがないときはExitSubしたいのですが、何処に記述すれば良いでしょうか？ Sub 削除() Dim i As Long If MsgBox("データを削除します。よろしいですか？", vbYesNo) = vbYes Then Sheets("リスト").Select i = 5 Do Until i = 200 If Cells(i, 5).Value = Sheets("マスタ登録").Range("D5") Then Cells(i, 1).EntireRow.Delete End If i = i + 1 Loop Else Exit Sub End If End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルVBAでConsolidate
以下は、ネット検索で見つけたサンプルコードです。 同じフォルダ内の全ブックのSheet１のA1:B10をThisWorkbookのSheet１に統合しています。 Sub test2() Dim MyFile As String, MyPath As String Dim SumFile() As Variant, i As Long MyPath = ThisWorkbook.Path & "\" MyFile = Dir(MyPath, vbNormal) Do Until MyFile = "" If MyFile <> ThisWorkbook.Name Then ReDim Preserve SumFile(i) 'A1からB10の値を変数に代入 SumFile(i) = "'" & MyPath & "[" & MyFile & "]Sheet1'!R1C1:R10C2" i = i + 1 End If MyFile = Dir Loop If i = 0 Then MsgBox "データが有りません": Exit Sub Worksheets("Sheet1").Range("A1").Consolidate Sources:=SumFile() End Sub 質問１ Sheet1だけでなく全シートのA1:B10をThisWorkbookのSheet１に統合するためにはどう書き換えればよいのでしょうか？ 質問２ 上記コードではなぜ、ブックを開かずにデータがとれるのでしょうか？
- ベストアンサー
- オフィス系ソフト
- VBA実行時のエラー
下記のプログラムは私が作った物では無いのですが、作った方と連絡をとる事が出来なくなってしまった為、質問させて頂きます。 このプログラムをシートから実行した所 エラー：400『既にフォームは表示されています。モーダルにできません。』 なるものが表示されてしまいます。 またコードを記述する所から実行しますと 実行時エラー：１００４『アプリケーション定義またはオブジェクト定義のエラー』 となってしまいます。 私の努力が足りないのは重々承知ですが、解決する事が出来ません。 皆様のお力を借りることが出来たらと思い投稿しました。 宜しくお願い致します。 Sub syoutotumen() Dim i As Long Dim j As Long Dim k As Long Dim kyori As Long Dim n As Integer n = 1 i = 1 j = 1 k = 1 Const cnsYEN = "\" Dim xlAPP As Application Dim objWBK As Workbook Dim strPATHNAME As String Dim strFILENAME As String strPATHNAME = "C:\Documents and Settings\tata41\デスクトップ\画像処理\" If strPATHNAME = "" Then Exit Sub strFILENAME = Dir(strPATHNAME & "dem******", vbNormal) If strFILENAME = "" Then MsgBox "このフォルダにはExcelワークブックは存在しません" Exit Sub End If Set xlAPP = Application With xlAPP .ScreenUpdating = False .EnableEvents = Fales .EnableCancelKey = xlErrorHandler .Cursor = xlWait End With Set WS1 = Worksheets("sheet1") Range("A1") = "0" Range("A2") = "1" Range("A1:A2").Select Selection.AutoFill Destinaton:=Range("A1:A512") Do While strFILENAME <> "" DoEvents If swESC = True Then If MsgBox("ESCが押されました。ここで終了しますか？", vbInformation + vbYesNo) = vbYes Then GoTo Button1_Click_Exit Else swESC = False End If End If xlAPP.StatusBar = trFILENAME & "処理中..." Set objWBK = Workbooks.Open(Filename:=strPATHNAME & cnsYEN & strFILENAME, UpdateLinks:=False, ReadOnly:=True) Do If Cells(i, 2) = 255 Then Exit Do i = i + 1 Loop Do If Cells(j, 3) = 255 Then Exit Do j = j + 1 Loop Do If Cells(k, 4) = 255 Then Exit Do k = k + 1 Loop kyori = (i + j + k - 21) / 3 WS1.Cells(n, 2) = kyori n = n + 1 i = 1 j = 1 k = 1 objWBK.Close savechanges:=False strFILENAME = Dir Loop GoTo Button1_Click_Exit Button1_Click_ESC: If Err.Number = 18 Then swESC = True Resume ElseIf Err.Number = 1004 Then Resume Next Else MsgBox Err.Description End If Button1_Click_Exit: With xlAPP .StatusBar = False .ScreenUpdating = True .EnableEvents = True .EnableCancelKey = xlInterrupt .Cursur = xlDefault Set objWBK = Nothing Set xlAPP = Nothing End With End Sub
- ベストアンサー
- オフィス系ソフト
- VBAにてアクティブでは無いシートの値が参照されてしまいます。
こんばんは、以前二回程質問させていただいた物です。 過去のアドバイスから少しずつ疑問をつぶしていった所再び問題が発生してしまいました。 同じプログラムを何度も載せるのは大変恐縮ですが、どうしても解決出来ない為(私の努力不足は重々承知です)皆様の力を貸して頂きたいと思います。 以下のようなループの際、途中にMsgBox(strFILENAME)を入れたり、Active.sheetでウオッチ式で見ても参照してほしいシート名を表示するにも関わらず、計算結果を書き込むシートのセルを参照してしまいます。 なぜ、WS1のセルの値を参照してしまうのかわからず困っています。 確実にMsgBox(strFILENAME)で表示されるファイル名のシートのセルを参照する方法を教えて頂きたく、よろしくお願いいたします。(Workbook.Worksheet.のように明示する方法を教えていただいたのですがエラーが発生してしまいうまく使いこなすことが出来ませんでした) どうか、宜しくお願いいたします。 Option Explicit Sub syoutotumen() Dim i As Long Dim j As Long Dim k As Long Dim kyori As Long Dim n As Integer n = 1 i = 1 j = 1 k = 1 Const cnsYEN = "\" Dim swESC As Boolean Dim ws1 As Worksheet Dim xlAPP As Application Dim objWBK As Workbook Dim strPATHNAME As String Dim strFILENAME As String strPATHNAME = "C:\Documents and Settings\tata41\デスクトップ\画像処理２\" If strPATHNAME = "" Then Exit Sub strFILENAME = Dir(strPATHNAME & "demo******", vbNormal) If strFILENAME = "" Then MsgBox "このフォルダにはExcelワークブックは存在しません" Exit Sub End If Set xlAPP = Application With xlAPP .ScreenUpdating = False .EnableEvents = False .EnableCancelKey = xlErrorHandler .Cursor = xlWait End With Set ws1 = Worksheets("sheet1") Range("A1") = "0" Range("A2") = "1" Range("A1:A2").Select Selection.AutoFill Destination:=Range("A1:A1022") Do While strFILENAME <> "" DoEvents If swESC = True Then If MsgBox("ESCが押されました。ここで終了しますか？", vbInformation + vbYesNo) = vbYes Then GoTo Button1_Click_Exit Else swESC = False End If End If xlAPP.StatusBar = strFILENAME & "処理中・・・" Set objWBK = Workbooks.Open(Filename:=strPATHNAME & cnsYEN & strFILENAME, UpdateLinks:=False, ReadOnly:=True) Do If Cells(i, 2) = 0 Then Exit Do i = i + 1 Loop Do If Cells(j, 3) = 0 Then Exit Do j = j + 1 Loop Do If Cells(k, 4) = 0 Then Exit Do k = k + 1 Loop kyori = (i + j + k - 21) / 3 ws1.Cells(n, 2) = kyori n = n + 1 i = 1 j = 1 k = 1 objWBK.Close savechanges:=False strFILENAME = Dir Loop GoTo Button1_Click_Exit Button1_Click_ESC: If Err.Number = 18 Then swESC = True Resume ElseIf Err.Number = 1004 Then Resume Next Else MsgBox Err.Description End If Button1_Click_Exit: With xlAPP .StatusBar = False .ScreenUpdating = True .EnableEvents = True .EnableCancelKey = xlInterrupt .Cursur = xlDefault Set objWBK = Nothing Set xlAPP = Nothing End With End Sub
- ベストアンサー
- オフィス系ソフト
- エクセル マクロ 初心者です
エクセルマクロ初心者です。 以下の２つの Private Sub Worksheet_Change(ByVal Target As Range)を１つのシートで実行させたいのですが、 当方、初心者なので組み合わせ方が分かりません。 よろしくお願いします。 ===No1=== Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Target = StrConv(Target, vbUpperCase) Application.EnableEvents = True End Sub ===No2=== Private Sub Worksheet_Change(ByVal Target As Range) Dim Ans As Integer If Target.Count = 1 Then Ans = MsgBox("コピーは禁止!!", vbCritical) MsgBox "データを消去します。" With Application .EnableEvents = False .Undo .EnableEvents = True End With End If If Target.Count = 1 Then Exit Sub Else MsgBox “複数セルのコピー禁止！" With Application .EnableEvents = False .Undo .EnableEvents = True End With End If End Sub ------------ 上記の２つを１つのシートで動作させたいのですが、うまくいきません。 単体では、動作します。
- ベストアンサー
- オフィス系ソフト
補足
補足遅くなってすいません。 (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)の部分っているのかなと思いました。 よろしくお願いします。