Visual Basic

A.exe ⇒ B.dllの関数 ⇒ C.dllの関数 の順で関数をコールするのですが、C.dllの関数をコールする際に DllNotFoundExceptionが出てしまいます（「'C.dll' を読み込めませんでした。」） また、上記エラーはPCによって発生しない場合もあるのですが、 原因として何が考えられるでしょうか。 動作確認したPCのフォルダ構成は同じで下記のようになっており、 EXEとDLLはすべて同じフォルダ内に存在しているため原因がよくわかりません。 BIN ├A.exe VB.net ├B.dll VB.net └C.dll C言語

宜しくお願いします。 A1～A10に数値、B1～B10に乱数を発生させて（RAND関数）、C1～C10にその順位を出す、その順位をG1～G10にコピー、F列に1行挿入、　 これを10回繰り返す。 マクロのボタンを１回押せば、これが実行される。これを５回したいときはボタンを５回押せばいい？これを実行できるコードがあるのでしょうか、わかりません。お教えください。

ネットから下記のコードを見つけたのですが、１つのシートに複数のオートシェイプの色塗りを変更する方法を教えてください。 例えばセル"A1"には数値の1と"A2"には数値2を入力したら、 オートシェイプAにはセル"A1"に対応した色塗り『赤色』を オートシェイプBにはセル"A2"に対応した色塗り『黄色』といった感じです。 下記のコードをいくつも繋げれば、複数のオートシェイプの色塗りが出来ると思ったのですが、コードを繋げる方法がわかりません。その他に何か良い方法がありましたら教えてください。 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address(0, 0) <> "A1" Then Exit Sub With ActiveSheet.Shapes("ABC").Fill.ForeColor Select Case Target.Value Case Is = "赤" .SchemeColor = 2 Case Is = "黄" .SchemeColor = 5 Case Is = "緑" .SchemeColor = 3 Case Is = "青" .SchemeColor = 4 Case Else .SchemeColor = 1 End Select End With End Sub

ExcelVBAマクロについて確認させてください。 関数の入ったWorksheets(1)をWorksheets(2)に関数ごとコピーさせてさらにTrim関数で文字列前後の空白を除去するコードを作成しましたが、Worksheets(2)では関数が消えてしまい、 値のみコピーになってしまいます。 関数ごとコピーしてさらに文字列前後の空白を除去するコードがあればお教えくださいm(__)m

vbdll.dll: int * __stdcall arr() { int a[] = {1,2,3}; return a; } vba: Declare Function arr Lib "C:\temp\vbdll.dll" () As Long() Sub test() Dim ccc() As Long ccc = arr Debug.Print ccc(0) End Sub インデックスが有効範囲にありませんになります 配列をDLLの戻り値としてVBAで受け取る書き方を教えてください？ 何卒、ご教授お願いします。

Excel の1つのファイル内の偶数番シートのA列が空白であるセルを行ごと削除したいのですが、下のコードではうまく動かないです。 シート番号はSheet(2)から(90)までです。 Sub 空白行削除() Dim i For i = 2 To 90 Step 2 Worksheets(i).Activate Columns("A:A").Select Selection.SpecialCells(xlCellTypeBlanks).Select Selection.EntireRow.Delete Next i End Sub

コンボボックスにclickイベントを書いたのち（この段階ではprivate） このコントロールをユーザコントロールにしました。 フォーム上に上記のユーザコントロールを配置したところ クリックイベントが発生しません クリックイベントを発生させるには 何か特殊な記述が必要ですか？（例えばオーバライドとか） どうすればクリックイベントを発生させられますか

accessへのインポートについて質問です。 VBAをつかってボタンを押すとファイル選択ダイアログが開き選択すると既存のテーブルへインポートするものを作成したいと考えています。 検索して出てきたものを加工して使ってみているのですが理想形になりません。 現状いまのままでも使えてはいるのですがより効率的にしたいと思っています。 具体的には以下の２点を修正したいと考えています。 ・元データは本来はＣＳＶのためＣＳＶのまま取り込みたい 範囲指定の際にExcelの関数を使って求めているためそれをCSV 現状はCSVを一度Excelに修正しています。 ・Ａ２のセルに日付（ユーザー定義ｙｙｙｙ年ｍｍ月ｄｄ日）が入っているためそれをUPDATEだデータに追加したい 現状は入力を求められるためそこに入力すると反映されます。 また、反映時はｙｙｙｙ/ｍｍ/ｄｄという表記で表示をしたいです。 一応Gとしてデータの取得はしていると思うのですがうまくいきません。 取り込むデータをCSVとExcelにしているのはもう一つ取込用のボタンがありそちらの取込はCSVだからです。 （CSVだけで取り込めるようになったらExcelは消します） 独学でネットにあるものをつまんでいる状況のため専門用語などが分からず説明が足りていないところなどありましたらご質問下さい。 宜しくお願い致します。 Private Sub コマンド1_Click() Dim msg As String msg = getFilePicker If msg = "" Then Exit Sub Dim objFileSys As Object Dim fileName As String Dim FN As Variant 'ファイルシステムを扱うオブジェクトを作成 Set objFileSys = CreateObject("Scripting.FileSystemObject") '拡張子無しのファイル名を取得 fileName = objFileSys.GetBaseName(msg) FN = objFileSys.GetAbsolutePathName(msg) Dim b As Long Dim r As Long Dim G As Date With CreateObject("Excel.Application") With .Workbooks.Open(FN) 'G = CDate(.Sheets(fileName).Range("A2").Value) b = .Sheets(fileName).Cells(1, 1).End(-4121).row .Close False End With End With DoCmd.TransferSpreadsheet acImport, , "T_G", msg, True, "B7:I" & b Dim sql As String DoCmd.SetWarnings WarningsOn:=False sql = "UPDATE T_G SET 入金日 = G WHERE Nz(入金日)=''" DoCmd.RunSQL sql DoCmd.SetWarnings WarningsOn:=True Set objFileSys = Nothing On Error GoTo err_sample err_sample: Select Case Err.Number Case 3011 MsgBox "ファイルが見つかりません。処理を終了します。" Case Else MsgBox Err.Number & ":" & Err.Description End Select End Sub Function getFilePicker(Optional dTitle As String = "ファイル選択") Const msoFileDialogFilePicker As Integer = 3 Dim fDlg As Object Set fDlg = Application.FileDialog(msoFileDialogFilePicker) fDlg.Title = dTitle fDlg.InitialFileName = "ダウンロード" '任意のフォルダパスを入れてください fDlg.AllowMultiSelect = False fDlg.Filters.Clear fDlg.Filters.Add "Excel Files(*.xls)", "*.xlsx;*.xls" fDlg.Filters.Add "Text Files(*.csv;*.txt)", "*.csv;*.txt" fDlg.FilterIndex = 1 If fDlg.Show Then getFilePicker = fDlg.SelectedItems(1) Else getFilePicker = "" End Function

Outlookでメールの本文をWordに貼り付けるマクロって作れませんか

VBA初心者です。 コードはネットで調べて組み合わせて作っております。 今回は、組み合わせたコードで処理が終わってもフォルダ内のファイル数の数だけ処理を繰返したいです。 事前に作っているコードは、 ①データ読み取りをしたいExcelを開く、別ブックを開いて該当のセルに入力。セル自体に数式が入っているので各シートに反映されます。 ②inputboxで各シートの該当セルに表示させたい文字を入力。 ③3、4枚目のシートを選択。 ④名前をつけて保存する。 という作業のコードになっています。 ①～④までを行った後に、データ数に応じて処理を繰返し行いたいです。 下記のコードにしたところ、Nextに対応するForがありません。とエラーが出ます。End Ifは追加しているのにエラーが起きるのはなぜでしょうか？ ---下記　コード--- Sub マスターデータ取込03() '選択したファイルを取り込み、別のファイルに貼り付ける。 For Each f In fso.GetFolder(folderpath).Files If fso.GetExtensionName Like "xls?" Then Set wb = Workbooks.Open(f) Dim RC As Integer Dim OpenFileName, FileName, Path, SetFile As String Dim wbMoto, wbSaki As Workbook Set wbMoto = ActiveWorkbook 'マスターデータ取り込み元をセット Application.DisplayAlerts = False RC = MsgBox("マスターデータ取込みますか？", vbYesNo + vbQuestion, "確認") If RC = vbYes Then OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls?") 'ダイアログボックスを表示して、マスターデータファイルを指定します。 If OpenFileName <> "False" Then SetFile = OpenFileName Else MsgBox "キャンセルされました" Exit Sub 'マスターデータの取り込みをキャンセル End If Workbooks.Open FileName:=SetFile, ReadOnly:=True, UpdateLinks:=0 'ダイアログボックスで指定したマスターデータファイルを開きます。 Set wbSaki = Workbooks.Open(Path & SetFile) 'ワークブック間のシート「項目」をコピーします。 wbSaki.Worksheets("内訳書").Range("D:O").Copy wbMoto.Worksheets("見積入力").Range("U7").PasteSpecial xlPasteValues Application.CutCopyMode = False 'コピー切り取りを解除 wbSaki.Close False 'マスターデータ取り込み先のファイルを閉じる Else MsgBox "処理を中断します" End If Application.DisplayAlerts = True Dim ans As String ans = InputBox("見積書・請求書No", "", "") If ans <> "" Then wbMoto.Worksheets("見積").Range("I3").Value = ans Worksheets("見積").Range("I3").Value = "ＶＨＭ-" & ans End If Application.DisplayAlerts = True ans = InputBox("見積書発行日", "", "") If ans <> "" Then wbMoto.Worksheets("見積").Range("F11").Value = ans End If ans = InputBox("完工日", "", "") If ans <> "" Then wbMoto.Worksheets("請求").Range("F11").Value = ans End If ans = InputBox("請求書発行日", "", "") If ans <> "" Then wbMoto.Worksheets("請求").Range("F12").Value = ans End If Worksheets(Array(2, 3)).Select ' 1 番目と 2 番目のシートを選択 Dim xFile xFile = Application.GetSaveAsFilename( _ FileFilter:="Excelファイル, *.xlsm") If TypeName(xFile) <> "Boolean" Then ActiveWorkbook.SaveAs FileName:=xFile End If Next End Sub

　PICとVisual basicで通信を行いたいです。 　全体的な仕組みとしてはPICでモーターなどを動かし、VBで現在どのようになっているのかパソコンの画面に映す…といった感じです。 　なので「PIC側のボタンを押せばVBの画面も一緒に変化する」、もしくは「VBでボタンをクリックするとPICのモーターも一緒に動く」といった信号を送る方法が知りたいです。 　プログラミングの勉強中なので完璧なプログラムを教えるのではなく、「○○って言葉で検索して」といったようなヒントを与える感じで答えていただけると幸いです。 　それと先日ZigBeeを使えるようになったので、それも使えたらなと考えています。

初めまして。 Excelで作成した報告書の印刷時にVBAを使い、B1セルに自動的に「提出済み」とスタンプ表示させています。ここまでのVBA組み立てはできたのですが、実際に使ってみると印刷中止にしても「提出済み」は表示されてしまいます。（印刷はされませんが） そこで皆さんにお聞きしたいのは、印刷を中止にした場合にこのスタンプをしないようにするVBAの書き方をお教えいただきたいのです。実際に現在組んでいるVBAは以下の通りです。 ★ThisWorkbookモジュールには下記を入力してます。 Private Sub Workbook_BeforePrint(Cancel As Boolean) Application.OnTime Now, "記録定着と提出記録押印" End Sub ★標準モジュールに下記を入力してます。 Sub 記録定着と提出記録押印() ' ' 記録定着値貼り付け2 Macro ' ' Cells.Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("A1").Select Application.CutCopyMode = False ActiveSheet.PrintOut preview:=True Range("b1") = "提出済み" ActiveSheet.Buttons.Delete Range("N24").Select End Sub 印刷前に値貼り付けをしているのは元の報告書は日付やほかのブックからデータを参照している関数が入っておりますので印刷時の状態を残すために値貼り付けを実施しています。 VBAは独学で学び中で未熟な者ですがご教示をよろしくお願いいたします。

VBA初心者です。よろしくお願いいたします。 次のVBAをエクセルで作成し、D:testというフォルダーにあるtest1.docxのB4判からA4判への縮小印刷と最初の１ページ目の印刷を試みています。結果として 縮小印刷にはなるのですが、１ページ目のみの印刷ではなくtest1.docxの全てのページが印刷されてしまいます。「PrintZoomPaperHeight:=16838」の記述に続けて「 , Pages:="1"」としてtest1.docxの最初の1ページだけ印刷する記述をしたのですが、どのような記述にすればよいのかご教示頂ければ幸いです。 Sub 印刷() Dim wdApp As Object, document As Object Const DIR_PATH As String = "D:test" Set wdApp = CreateObject("Word.Application") wdApp.Visible = True Set document = wdApp.Documents.Open(DIR_PATH & "\" & "test1.docx") document.PrintOut PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=11906, PrintZoomPaperHeight:=16838 , Pages:="1" document.Close wdApp.Quit End Sub

ExcelVBAマクロについて確認させてください。 これは「Internet Explorer（IE）」になっているので「Microsoft Edge」また「Google Chrome」ソフトに変更する場合はどのように変更すればよいかご教授くださいm(_ _)m 下記のプログラムの具体的な仕様 １）現在開いているInternet ExplorerのWebサイトアドレスをA1セルから順に出力する。 ２）A1セルに主力したWebサイトアドレスを一つずつ開いて、閉じる。 Sub test() '現在開いているURLの取得 Dim sh As Object Dim win As Object Dim buf As String Dim i As Integer Dim n As Integer Dim strUrl As String Set sh = CreateObject("Shell.Application") For Each win In sh.Windows 'ウインドウの数だけ回す If win.Name = "Internet Explorer" Then buf = buf & " " & win.LocationURL End If Next '空白毎に区切ってセルに代入 Worksheets(1).Range("A1").Resize(UBound(Split(Trim(buf), " ")) + 1).Value = WorksheetFunction.Transpose(Split(Trim(buf), " ")) i = Worksheets(1).Cells(1, 1).End(xlDown).Row '現在開いているURLの数を取得 For n = 1 To i strUrl = Worksheets(1).Cells(n, 10) '文書策定画面を文字列strUrlに代入 'IEオブジェクトを作成 Dim ie As InternetExplorer Set ie = New InternetExplorerMedium 'IEを表示（見えるようにする） ie.Visible = True '指定したURLをIEで開く ie.navigate strUrl 'サイトの読み込みが完了するまで待つ Do While ie.Busy = True Or ie.readyState < READYSTATE_COMPLETE DoEvents Loop 'オブジェクトを閉じる ie.Quit 'メモリからオブジェクトを破棄 Set ie = Nothing Next n End Sub

下図で状況を説明します。 ①中央の「ｼｰﾄ名変更」ﾌﾞｯｸの全ｼｰﾄについて、各ｼｰﾄのE1ｾﾙをｷｰとして、VLOOKUPでｼｰﾄ名を左の「ｼｰﾄ名ﾏｸﾛ」ﾌﾞｯｸから拾い、「ｼｰﾄ名変更」ﾌﾞｯｸの各ｼｰﾄのA1ｾﾙに一旦表示させます。(本当はｼｰﾄ名をﾀﾞｲﾚｸﾄに変えたい) ②「ｼｰﾄ名変更」ﾌﾞｯｸのA1ｾﾙに表示された文言を、そのｼｰﾄのｼｰﾄ名とします。 ③「ｼｰﾄ名変更」ﾌﾞｯｸの全てのｼｰﾄが同じ書式である為、最終ｼｰﾄ迄①/②を繰り返します。 現状、右の様にｺｰﾄﾞを書きましたが、上手く動くのがｱｸﾃｨﾌﾞｼｰﾄのみとなり、次のｼｰﾄに処理が移行しません。 間違いを教示頂きたく、宜しくお願いします。

下記のマクロは、選択したセルのURLからサイトタイトルを取得するものです。 このマクロを使って、１万を越えるURLの作業をやろうとしています。 作業に取り掛かったのですが、下記のマクロがすぐに「応答なし」になり、 エクセルの画面が真っ白になり、Escでマクロを止めることもできません。 ようやくマクロを止めても応答なしのときはマクロが動いておらず、作業が進みません。 取得するサイトタイトルの数が多いため、 寝てるときにマクロを動かしてやっていきたいです。 下記のマクロを「応答なし」にせずに、順調にサイトタイトルを取得していくには、 どのような記述にすれば、できるようになるでしょうか？ EXCEL2016です。 よろしくお願いいたします。 ↓応答なしになるマクロ Sub サイトタイトル() Dim rng As Range Dim url As String Dim s As String For Each rng In Selection url = rng.Value If url <> "" Then If url Like "*://*" Then s = GetTitle(rng.Value) Else s = GetTitle("https://" & url) If s = "Error" Then s = GetTitle("http://" & url) If s = "Error" Then s = GetTitle("https://www." & url) If s = "Error" Then s = GetTitle("http://www." & url) End If rng.Offset(, 1) = s End If Next End Sub Function GetTitle(url As String) As String Dim http As Object Dim html As Object Set http = CreateObject("MSXML2.XMLHTTP") Set html = CreateObject("htmlfile") GetTitle = "Error" On Error Resume Next http.Open "GET", url, False http.send If http.Status <> 200 Then Exit Function On Error GoTo 0 html.Write http.responseText GetTitle = html.Title End Function

エクセルVBAで以下のようなデータがあります。 D列の文字列と右隣のE列の文字列の2つが入っているものをA列から探し、見つかったセルの上にセルを追加し、E列の右隣のF列に入っている文字列を代入したいです。 どのようなプログラムになりますか？

VBAは全くの素人です。 マクロの記録とInterNetでVBAコードを探し、下記のように記しました。 VBAのデバッグ＆ステップインで（動作）確認するのですが、素人の悲しさか、Do Until IF の行で「コンパイル＆構文エラー」に引っ掛かり先に進めません。 どの様に修正したらよいのかnetを探すのですが見つかりません。(探し方が足りない？) コードの右側に ‘‥‥やりたい事のコメントを記しています。 どの様にコードを修正したらよいのか、ご指導願えませんでしょうか？。 他の部分についてもご指導頂けると助かります。 Sub 練習1() Dim i As Integer '‥‥変数(繰り返し回数のカウント) iを宣言 i = 0 '‥‥変数iをﾘｾｯﾄ(0)にする(繰り返し回数のカウント) Range("$F$8").Select ActiveCell.FormulaR1C1 = 0 '‥‥F8をﾘｾｯﾄ(0)にする Dim waittime As Variant '‥‥待ち時間設定宣言 waittime = Now + TimeValue("0:00:10") '‥‥待ち時間10秒に設定 Do Until If Range("$G$8").Value = "Out" Then '‥‥「Goodになるまで繰り返しなさい」 Calculate ‘‥‥繰り返し計算せよ Else: Range("$G$8").Value = "Good" ‘‥‥Goodになれば繰り返し(Loop)完了 IF Range("$G$8").Value = Interior.colorIndex = 36 '‥‥$G$8が"Good"ならばセル色を36にする '尚、G8セルの計算式は=IF(AND($I$25="OK",$I$26="OK",$I$27="OK"，$I$28="OK",$I$29="OK"),"Good","Out") Range("F8").Select ActiveCell.FormulaR1C1 i = i + 1 '‥‥変数iを1増やす(繰り返し回数のカウント) waittime = Now + TimeValue("0:00:10") '‥‥待ち時間10秒に設定 End If Calculate Loop '‥‥G8が”Good” になればVBA終了 Range("G8").Select End Sub

下記のマクロは、指定範囲のURL先のソースに、 指定した語句があれば、○を付けるマクロです。 指定した語句をソース全て対象にせずに、 <title></title>のサイトタイトルの中に、"【"があれば○を付けるというようにしたいです。 （クォーテーションマーク抜きの【） https://okwave.jp/qa/q9899670.html こちらで先に質問をして回答をいただいたのが、 元のコードの一部を、 If sHtml Like "*<title>*" & "【" & "*</title>*" Then aCell.Offset(, 1).Value = "○" Else aCell.Offset(, 1).Value = "--" End If に変更するというものです。 しかし、これだとUTF-8のサイトは認識できますが、 Shift_JISのサイトでは認識できないようです。（【があるのに、○が付かない） UTF-8とShift_JISのサイト両方を認識して、 "【"が、<title></title>の中にあるものに○を付くようにするには、 どのようなマクロの記述になりますでしょうか？ よろしくお願いいたします。 Sub 指定した語句() '!!!! [Microsoft XML v6.0] に参照設定すること Dim xHttp As IServerXMLHTTPRequest Dim myErr_Number As Long, myErr_Description As String Set xHttp = CreateObject("MSXML2.ServerXMLHTTP") Dim aCell As Range R = 1 For Each aCell In Selection.Columns(1).Cells '選択セルの1列目がURL Application.Goto aCell '対象URLの列にジャンプ表示 DoEvents sUrl = aCell.Value If sUrl <> "" Then xHttp.Open "GET", sUrl, True xHttp.setOption SXH_OPTION_IGNORE_SERVER_SSL_CERT_ERROR_FLAGS, _ SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS ' SSL関係のエラーを無視 On Error Resume Next xHttp.send If xHttp.readyState <> 4 Then xHttp.waitForResponse 5 '5秒まってだめならタイムアウト End If If xHttp.readyState <> 4 Then Err.Raise 1004, , "タイムアウト" myErr_Number = Err.Number myErr_Description = Err.Description On Error GoTo 0 If myErr_Number = 0 Then sHtml = xHttp.responseText nRtn = InStr(sHtml, "指定した語句") If nRtn = 0 Then aCell.Offset(, 1).Value = "--" Else aCell.Offset(, 1).Value = "○" End If Else aCell.Offset(, 1).Value = myErr_Description ' エラー時はエラー内容を表示 End If DoEvents End If Next Set xHttp = Nothing End Sub

下記のマクロは、指定範囲のURL先のソースに、 指定した語句があれば、○を付けるマクロです。 指定した語句をソース全て対象にせずに、 <title></title>のサイトタイトルの中にあれば、○を付けるというようにしたいです。 ちなみに、調べたいのは語句ではないですが、"【"というカッコです。 ・下記のマクロ URL先のソース全体の中に、指定した語句があれば○ ・希望のマクロ <title></title>（サイトタイトル）の中に、指定した語句があれば○ どの部分を修正、または追加すればできるようになりますか？ よろしくお願いいたします。 Sub 指定した語句() '!!!! [Microsoft XML v6.0] に参照設定すること Dim xHttp As IServerXMLHTTPRequest Dim myErr_Number As Long, myErr_Description As String Set xHttp = CreateObject("MSXML2.ServerXMLHTTP") Dim aCell As Range R = 1 For Each aCell In Selection.Columns(1).Cells '選択セルの1列目がURL Application.Goto aCell '対象URLの列にジャンプ表示 DoEvents sUrl = aCell.Value If sUrl <> "" Then xHttp.Open "GET", sUrl, True xHttp.setOption SXH_OPTION_IGNORE_SERVER_SSL_CERT_ERROR_FLAGS, _ SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS ' SSL関係のエラーを無視 On Error Resume Next xHttp.send If xHttp.readyState <> 4 Then xHttp.waitForResponse 5 '5秒まってだめならタイムアウト End If If xHttp.readyState <> 4 Then Err.Raise 1004, , "タイムアウト" myErr_Number = Err.Number myErr_Description = Err.Description On Error GoTo 0 If myErr_Number = 0 Then sHtml = xHttp.responseText nRtn = InStr(sHtml, "指定した語句") If nRtn = 0 Then aCell.Offset(, 1).Value = "--" Else aCell.Offset(, 1).Value = "○" End If Else aCell.Offset(, 1).Value = myErr_Description ' エラー時はエラー内容を表示 End If DoEvents End If Next Set xHttp = Nothing End Sub