- ベストアンサー
VBA初心者が困っているところ
ham_kamoの回答
- ham_kamo
- ベストアンサー率55% (659/1197)
まずは疑問点から。 > 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 の下に追加してください。
関連する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)分かりやすい説明ありがとうございました！ (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 でよろしいのでしょうか？ よろしくお願いします。