Visual Basic

全22309件中1~20件表示
  • Excelの画像一括挿入マクロを改良したい

    以下の質問の回答者さんの頂戴し少し改変して、マクロでExcelの画像を一括挿入しています。 https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q12139845762 貼り付けるセルが一列に並び画像を連続して下に貼り付けるだけであればこちらのマクロで大丈夫なのですが、 貼り付けるセルが2列3行になり、 1番目の写真  2番目の写真 3番目の写真  4番目の写真 5番目の写真  6番目の写真 という風に貼り付けたいときにどうしたらよいのかがわかりません。 ActiveCell.Offset(21).Select の所で、セルの行が21下がって貼り付けられるということはわかるのですが… 使っているExcelファイルはいわゆるセルが方眼紙のようになっており、15行19列のセルを結合してそこに写真を貼り付けています。 1番目の写真を貼り付けた後に2列移動して貼り付けたいです。 ご教授いただければ幸いです。 使用しているマクロ↓ Sub ShpAdTest() Dim FNames As Variant, myShp As Shape Dim Fn As String, i As Long FNames = Application.GetOpenFilename( _ filefilter:="Image(*.jpg;*.gif;*.bmp;*.png),*.jpg;*.gif;*.bmp;*.png", _ Title:="図の挿入(複数選択可)", _ MultiSelect:=True) If Not IsArray(FNames) Then Exit Sub Call BubbleSort_Str(FNames, True, vbTextCompare) Application.ScreenUpdating = False For i = LBound(FNames) To UBound(FNames) PasteShp (FNames(i)) With ActiveSheet.Shapes(ActiveSheet.Shapes.Count) .LockAspectRatio = msoTrue .Placement = xlMove .DrawingObject.PrintObject = True .Height = ActiveCell.MergeArea.Height If .Width > ActiveCell.MergeArea.Width Then .Width = ActiveCell.MergeArea.Width End If .Top = ActiveCell.MergeArea.Top + (ActiveCell.MergeArea.Height - .Height) / 2 .Left = ActiveCell.MergeArea.Left + (ActiveCell.MergeArea.Width - .Width) / 2 End With ActiveCell.Offset(21).Select Next Call ShpCutPaste Application.ScreenUpdating = True End Sub Sub PasteShp(fname As Variant) Dim Shp As Shape Set Shp = ActiveSheet.Shapes.AddPicture( _ filename:=fname, _ linktofile:=False, savewithdocument:=True, _ Left:=Selection.Left, Top:=Selection.Top, _ Width:=0, Height:=0) Shp.ScaleHeight 1!, msoTrue Shp.ScaleWidth 1!, msoTrue Set Shp = Nothing End Sub Private Sub BubbleSort_Str( _ ByRef Source As Variant, _ Optional ByVal SortAsc As Boolean = True, _ Optional ByVal Compare As VbCompareMethod = vbTextCompare) If Not IsArray(Source) Then Exit Sub Dim i As Long, j As Long Dim vntTmp As Variant For i = LBound(Source) To UBound(Source) - 1 For j = LBound(Source) To LBound(Source) + UBound(Source) - i - 1 If StrComp(Source(IIf(SortAsc, j, j + 1)), _ Source(IIf(SortAsc, j + 1, j)), Compare) = 1 Then vntTmp = Source(j) Source(j) = Source(j + 1) Source(j + 1) = vntTmp End If Next j Next i End Sub ' ↓ 画像のリンク解除と画像ファイルサイズの低減 Private Sub ShpCutPaste() Dim Shp As Shape, Nm As String Dim x As Double, y As Double Application.ScreenUpdating = False For Each Shp In ActiveSheet.Shapes With Shp x = .Left y = .Top Nm = .Name .Cut End With ActiveSheet.PasteSpecial Format:="図 (JPEG)", _ Link:=False, DisplayAsIcon:=False With Selection .Left = x .Top = y .Name = Nm End With Application.CutCopyMode = False Next Application.ScreenUpdating = True End Sub

  • 検索結果が○件以下だったら隣に○

    C1から下へずらーっと、キーワードや文章が記入されています。 このセル内のキーワードをGoogle検索して、『検索結果が○件以下だったら隣に○』 という風に分けていきたいです。 こういう作業は、マクロでできるでしょうか? どのような記述でできますか? EXCEL2016です。 よろしくお願いいたします。

  • Excel ブック内の指定したデータのコピーマクロ

    よろしくお願いします。 エクセルで自動登録で自動化をしていますが、これだと限界があり今回こちらに書き込みさせていただきました。 流れとしては、マクロスタートでダイアログがでて(可能なら奥底に格納されるブックなのでそのフォルダの一個前辺りの階層指定されて)そこで指定した毎日新しく作られるブック内の指定したシートの指定したセルにあるデータをコピー(ブックは開かないで読み込み)してテンプレートととしている空のブックを開き(開いたまま)指定したシートの指定したセルにペーストするマクロを作りたいです。 (指定したシートと指定したセルの名前は常に同じです) 自動記録で指定したブックを開いて読み込む事は出来ましたが、毎回別のブックなのでそれでは事足りないのです。 ネットで探しましたが… ・ダイアログでファイルを開くマクロは見つけましたが、開いた後内部のデータを読み込むなどマクロは見つかりませんでした。 つながるところがわかりません。 ・(存在するブックの場所指定で)ブックを開かないでその中のデータを読み込むマクロは見つけましたが、ダイアログで選ぶけど開かないでと言う事が出来るマクロは見つけられませんでした これらは元々出来ないのでしょうか? 可能で有ればご教示下ださると助かります。 よろしくお願いします。

  • hta vbscriptでリセットボタン

    Htaの入力フォームで入力したデータをリセットするボタンを作りたいです。 詳しい方教えてくれると嬉しいです。 ボタンの設置方法 リセット可能な範囲の指定の仕方 よろしくお願いします

  • ExcelVBAマクロで貼り付け先の配列化について

    ExcelVBAマクロについて確認させてください。 プログラム高速化のために2番目のワークシート貼り付け先範囲を配列化しました。 1番目のワークシートの文字をtrim関数によって前後の空白を除去したうえで2番目のワークシートに貼り付けようとしていますが、空白が除去できていない状況です。 何か原因なのでしょうかm(__)m Sub test() Dim x As Long Dim y As Long Dim x2 As Long Dim y2 As Long Dim a As String Dim Table As Variant '配列化のため '最大列取得 x = Worksheets(1).Cells(1, Columns.Count).End(xlToLeft).Column '最大行取得 y = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row Table = Worksheets(2).Range(Worksheets(2).Cells(1, 1), Worksheets(2).Cells(y, x)) '貼り付け先範囲を配列化 For x2 = 1 To x '最大列 For y2 = 1 To y '最大行 a = Worksheets(1).Cells(y2, x2).Value Table(y2, x2) = Trim(a) 'ワークシート1の値から前後空白を取り除いてワークシート2に貼り付け Next Next End Sub

  • DLLインポートについて

    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回繰り返す。 マクロのボタンを1回押せば、これが実行される。これを5回したいときはボタンを5回押せばいい?これを実行できるコードがあるのでしょうか、わかりません。お教えください。

  • エクセルVBAでの複数のオートシェイプの色塗り方法

    ネットから下記のコードを見つけたのですが、1つのシートに複数のオートシェイプの色塗りを変更する方法を教えてください。 例えばセル"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マクロで関数ごとコピー後空白削除

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

  • 配列をDLLの戻り値としてVBAで受け取る書き方

    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 偶数番シートのA列が空白であるセル削除

    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

    • ベストアンサー
    • 困ってます
    • N007
    • Visual Basic
    • 回答数 3
  • VB6 ユーザコントロールでクリックイベント

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

  • accessのVABを使ったインポートについて

    accessへのインポートについて質問です。 VBAをつかってボタンを押すとファイル選択ダイアログが開き選択すると既存のテーブルへインポートするものを作成したいと考えています。 検索して出てきたものを加工して使ってみているのですが理想形になりません。 現状いまのままでも使えてはいるのですがより効率的にしたいと思っています。 具体的には以下の2点を修正したいと考えています。 ・元データは本来はCSVのためCSVのまま取り込みたい 範囲指定の際にExcelの関数を使って求めているためそれをCSV 現状はCSVを一度Excelに修正しています。 ・A2のセルに日付(ユーザー定義yyyy年mm月dd日)が入っているためそれをUPDATEだデータに追加したい 現状は入力を求められるためそこに入力すると反映されます。 また、反映時はyyyy/mm/ddという表記で表示をしたいです。 一応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で

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

  • 【VBA】一番初めの処理に戻って、処理を繰り返す。

    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 = "VHM-" & 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とVB.netとの通信

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

  • ExcelVBAを使った印刷のことで教えてください

    初めまして。 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初心者です。よろしくお願いいたします。 次のVBAをエクセルで作成し、D:testというフォルダーにあるtest1.docxのB4判からA4判への縮小印刷と最初の1ページ目の印刷を試みています。結果として 縮小印刷にはなるのですが、1ページ目のみの印刷ではなく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

  • VBAでMicrosoft Edgeから開く方法

    ExcelVBAマクロについて確認させてください。 これは「Internet Explorer(IE)」になっているので「Microsoft Edge」また「Google Chrome」ソフトに変更する場合はどのように変更すればよいかご教授くださいm(_ _)m 下記のプログラムの具体的な仕様 1)現在開いているInternet ExplorerのWebサイトアドレスをA1セルから順に出力する。 2)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

  • 【VBA】全てのシートに処理

    下図で状況を説明します。 ①中央の「シート名変更」ブックの全シートについて、各シートのE1セルをキーとして、VLOOKUPでシート名を左の「シート名マクロ」ブックから拾い、「シート名変更」ブックの各シートのA1セルに一旦表示させます。(本当はシート名をダイレクトに変えたい) ②「シート名変更」ブックのA1セルに表示された文言を、そのシートのシート名とします。 ③「シート名変更」ブックの全てのシートが同じ書式である為、最終シート迄①/②を繰り返します。 現状、右の様にコードを書きましたが、上手く動くのがアクティブシートのみとなり、次のシートに処理が移行しません。 間違いを教示頂きたく、宜しくお願いします。