回答数
気になる
-
Excelのマクロについて教えてください。
下記のマクロはネットから参照したマクロで、マクロを実行すると指定フォルダが圧縮できます。 このマクロでが圧縮対象のフォルダを targetPath = "C:\Users\160931\Desktop\ファイル更新(最新)\テスト物件\12345678-5_交付用" '作成するZIPファイルのパスを zipFilePath = "C:\Users\160931\Desktop\ファイル更新(最新)\テスト物件\12345678-5_交付用.zip" に指定しておりますが、 この指定を マクロ設定ブックと同じフォルダ内にある、フォルダ「12345678-5_交付用」に変更出来る方法を教えてください。 尚、圧縮対象フォルダは1つしか無く、「_交付用」は固定フォルダ名になりますが、 「_交付用」から前の部分(12345678-5)は物件毎に変更になる為、 ' フォルダ名が「8桁の英数字-1_交付用」というパターンに一致する場合 If folderName Like "########-#_交付用" Then のような設定を希望いたします。 現状のマクロ Sub フォルダを圧縮() Dim targetPath As String Dim zipFilePath As String Dim psCommand As String Dim wsh As Object Dim result As Integer 'ZIP形式で圧縮するフォルダ(またはファイル)パスを指定 targetPath = "C:\Users\160931\Desktop\ファイル更新(最新)\テスト物件\12345678-5_交付用" '作成するZIPファイルのパスを指定 zipFilePath = "C:\Users\160931\Desktop\ファイル更新(最新)\テスト物件\12345678-5_交付用.zip" '実行するPowerShellのコマンドレットを組み立て psCommand = "powershell -NoProfile -ExecutionPolicy Unrestricted Compress-Archive -Path " & targetPath & " -DestinationPath " & zipFilePath & " -Force" Set wsh = CreateObject("WScript.Shell") 'PowerShellのコマンドレットを実行 result = wsh.Run(Command:=psCommand, WindowStyle:=0, WaitOnReturn:=True) If (result = 0) Then MsgBox ("圧縮が正常終了しました。") Else MsgBox ("圧縮が異常終了しました。") End If '後片付け Set wsh = Nothing End Sub 以上となります。 宜しくお願い致します。
質問日時: 2024/11/18 09:09 質問者: エクセル小僧
ベストアンサー
1
0
-
VBAのループ処理について教えてください
Sub AA() If Range("D60") Like "*入*" Then Range("AM60:AP60").Interior.Color = RGB(255, 0, 0) ' セルが赤色 ElseIf Range("D60") Like "*退*" Then Range("AL60:AM60").Interior.Color = RGB(255, 0, 0) ' セルが赤色 ElseIf Range("D60") = "空" Then Range("AL60:AN60").Interior.Color = RGB(255, 0, 0) ' セルが赤色 End If End Sub 上記の式はシートの60行目についての処理ですが、これを102行目まで同列で同じ処理をしたい場合のループ処理の記載方法を教えて頂きたいです。。。 よろしくお願いいたします。
質問日時: 2024/11/15 11:47 質問者: ya00623
ベストアンサー
3
0
-
修正依頼:【VBA】 結合セルに複数画像とファイル名一括挿入する方法
ご覧いただきありがとうございます。 以前、「ダイアログボックスを開き画像ファイルを選択、1行目が見出し行になっている表のB2から6行ごとに結合したセルに画像を挿入し、隣のC列(6行ごと結合)に画像ファイル名(拡張子なし)が入る表を作る」という件で以下のコードを作成していただいたのですが、 画像がリンク貼り付けになってしまい、メール等で送信すると見れなくなってしまいます。 リンクではなく画像として挿入するためにはどうしたらいいでしょうか? 詳しい方、よろしくお願いいたします。 Sub Sample() Dim i As Long, fileName As String Dim rng As Range, sItems With Application.FileDialog(msoFileDialogFilePicker) .Title = "Select Image Files" .Filters.Clear .Filters.Add "Image Files", "*.GIF; *.JPG; *.BMP; *.PNG; *.TIF", 1 .AllowMultiSelect = True If .Show = 0 Then Exit Sub Set sItems = .SelectedItems End With For i = 1 To sItems.Count fileName = Dir(sItems(i)) Set rng = Cells(i * 6 - 4, 2) rng.Offset(, 1).Value = Left(fileName, InStrRev(fileName, ".") - 1) Set rng = rng.MergeArea With ActiveSheet.Pictures.Insert(sItems(i)) .Left = rng.Left .Top = rng.Top .Placement = xlMoveAndSize .ShapeRange.LockAspectRatio = msoFalse .ShapeRange.Width = rng.Width .ShapeRange.Height = rng.Height End With Next i End Sub
質問日時: 2024/11/14 16:46 質問者: ukr-pm
ベストアンサー
2
1
-
4
Excelのマクロについて教えてください。
下記のマクロは先日教えて頂いたマクロで、マクロを実行すると フォルダ:検査時必要図書(正本)の中にある、PDFファイルを フォルダ:########-#_交付用 にコピーできます。 このコードを フォルダ:検査時必要図書(正本)を無くして マクロ設定ブックと同じフォルダ内にあるPDFファイルを マクロ設定ブックと同じフォルダ内にある フォルダ:########-#_交付用 に移動出来る方法を教えてください。(親切に詳しいコード共教えてください) 宜しくお願い致します。 現状のマクロ Sub 交付用に移動() On Error Resume Next Dim myPath As Variant Dim fPath As String, fname As String fPath = ThisWorkbook.Path ' myPath 変数にフォルダパスを取得 myPath = folder_acquisition(fPath) ' 「交付用_A3」で終わるPDFファイルを取得 fname = Dir(myPath(1) & "*(交付用_A3).pdf") Do While fname <> "" ' ファイルのコピーを実行 FileCopy myPath(1) & fname, myPath(2) & fname fname = Dir Loop End Sub Function folder_acquisition(fPath As String) As Variant() Dim fso As Object, f As Object Dim n As Integer Dim myPath(2) As Variant Set fso = CreateObject("Scripting.FileSystemObject") ' 検査時必要図書(正本)フォルダの取得 myPath(1) = fPath & "\検査時必要図書(正本)\" ' フォルダ内のサブフォルダを走査し、「_交付用」で終わるものを見つける For Each f In fso.GetFolder(fPath).SubFolders Dim folderName As String folderName = Mid(f.Path, InStrRev(f.Path, "\") + 1) ' フォルダ名が「8桁の英数字-1_交付用」というパターンに一致する場合 If folderName Like "########-#_交付用" Then myPath(2) = f.Path & "\" n = n + 1 End If ' 必要なフォルダが見つかったら終了 If n = 2 Then Exit For Next f Set fso = Nothing folder_acquisition = myPath() End Function 以上となります。 宜しくお願い致します。
質問日時: 2024/11/13 14:05 質問者: エクセル小僧
ベストアンサー
2
0
-
5
Excelのマクロについて教えてください。
下記のマクロを以下の条件のように変更出来る方法を教えてください。 マクロを実行するとワイルドカード名のPDFファイルが指定フォルダから指定フォルダ内にコピーされます。 コードの「Case "検査時必要図書(正本)"」ですが、マクロを設定しているフォルダを指定 (仮に今回はフォルダを「テスト部件」としてます。 コードの「Case "返却用(副本)"」ですがマクロを設定しているフォルダ内のフォルダを指定 (今回は:24110955-1_交付用となっておりますが、最初「_」前の半角英数字と8文字と「-」以下の半角英数字と1文字は物件によって変更されますが、「_交付用」は変更されません。 画像のように テスト物件フォルダ内にある「24001234-1_(仮称)北海太郎(交付用_A3).pdf」を 同じくテスト部件内にあるフォルダ名「24001234-1_交付用」内にコピーを出来る方法を教えてください。 できるだけ詳しいコード迄、親切に教えてください。 現状のマクロ Sub 交付用() On Error Resume Next Dim myPath As Variant Dim fPath As String, fname As String fPath = ThisWorkbook.Path fPath = Left(fPath, InStrRev(fPath, "\") - 1) myPath = folder_acquisition(fPath) fname = Dir(myPath(1) & "*(交付用_A3).pdf") Do While fname <> "" FileCopy myPath(1) & fname, myPath(2) & fname fname = Dir Loop End Sub Function folder_acquisition(fPath As String) As Variant() Dim fso As Object, f As Object Dim n As Integer Dim myPath(2) As Variant Set fso = CreateObject("Scripting.FileSystemObject") With fso For Each f In .GetFolder(fPath).SubFolders Select Case Mid(f.Path, InStrRev(f.Path, "\") + 1) Case "検査時必要図書(正本)" myPath(1) = f.Path & "\" n = n + 1 Case "返却用(副本)" myPath(2) = f.Path & "\" n = n + 1 End Select If n = 2 Then Exit For Next f End With Set fso = Nothing folder_acquisition = myPath() End Function 以上となります。
質問日時: 2024/11/08 15:17 質問者: エクセル小僧
ベストアンサー
1
0
-
6
VBA 2次元配列の出力
EXCEL Microsoft365 VBAで、2行、179997列の2次元配列があります。 1行目には時刻、2行目には数値データがはいっています。 この配列について、A1セルをリサイズ、行列変換して出力することで、 A列に時刻、B列に数値データの一覧がほしいです。 しかし、出力すると、48926行目で、次の行以降が勝手にB列に折り返されて出力されてしまいます。 配列には正しくデータが入っていることを確認しているのですが、出力する際に、特定の行以降が次の行に出力されてしまい、 A列とB列に時刻が出力されてしまい、数値データが出力されません。 なお、48926行から179997行までは#N/Aとなっています。 データ数を少なくした場合(2行10列)で実行したときには問題なく出力されましたので、コード上に問題はないと思っています。
質問日時: 2024/10/26 17:22 質問者: ぶつりがくっておいしいの
ベストアンサー
1
0
-
7
Excelのマクロについて教えてください。
下記のマクロを実行すると、 指定セル値がファイル名となり、保存され、マクロ設定ブックが、削除されます。 このマクロを下記の様に変更する方法を教えてください。 シート名「新料金算定表2024.05」の指定セル「AS2」に(確認)と表示された場合のみこのマクロが実行でき。 シート名「新料金算定表2024.05」の指定セル「AS2」に(確認)と表示されていない場合は、メッセージボックスで(料金表を確認後、保存してください)とメッセージが表示され、マクロを実行する事が出来ないように出来る方法を教えてください。 現状のマクロ Sub 名前を付けて保存ファイル削除() Dim alert As VbMsgBoxResult alert = MsgBox("名前を付けて保存を行いますか?", vbYesNo + vbQuestion, "保存確認") If alert <> vbYes Then Exit Sub End If On Error Resume Next Dim newName As String newName = Sheets("受付・名簿・日付").Range("B54").Value Dim ws As Worksheet Dim TargetCheck As String Dim List As Variant Dim i As Long Dim Chk As Boolean For Each ws In Worksheets Chk = False If ws.Visible = False Then For i = 0 To UBound(List) If ws.Name = List(i) Then Chk = True Exit For End If Next i If Chk = False Then TargetCheck = TargetCheck & ws.Name & vbCrLf Application.DisplayAlerts = False ws.Delete Application.DisplayAlerts = True End If End If Next ws Dim oldName As String oldName = ThisWorkbook.Path & "\" & ThisWorkbook.Name With ThisWorkbook Application.DisplayAlerts = False .SaveAs .Path & "\" & newName, xlOpenXMLWorkbookMacroEnabled Application.DisplayAlerts = True End With Kill oldName Application.ScreenUpdating = True Application.Quit With ThisWorkbook .Saved = True .Close False End With End Sub 以上です。宜しくお願い致します。
質問日時: 2024/10/24 09:27 質問者: エクセル小僧
ベストアンサー
2
0
-
8
ExcelのVBAコードについて教えてください。
マクロ設定ブックに シート名「受付」「青紙表」「1」と「審査」があります。 作業の流れで、シート名「1」を表示して、作業を行う必要がありますが 度々失念してしまう事があり、マクロ等を設定し、この失念を防止したいと考えております。 私の希望ですが、 シート名「1」を1回でも表示しないと、シート名「審査」のシートに移動できないように設定できるマクロを教えてください。 その時にメッセージボックスが表示され、(シート「1」の作業が完了しておりません。作業を完了してください。)と表示出来る方法もお願いいたします。 又、このVBAコードをどこのシートに設定又はThisWorkbook を含めて親切にコード共教えください。 宜しくお願い致します。
質問日時: 2024/10/23 11:58 質問者: エクセル小僧
ベストアンサー
2
1
-
9
Excelのマクロについて教えてください。
下記のマクロは以前教えて頂いたマクロで、このマクロを実行すると ダイアログが開き指定したPDFファイルを指定セル値にてファイル名が変更され、 マクロ設定ブックと同じフォルダ内に保存されます。 ファイル名を変更したファイルの保存先をマクロ設定ブックと同じフォルダ内では無く 変更したいファイル名を変更したい「PDFファイル」があるフォルダ内にそのまま指定セル値でのファイル名に変更して保存できる方法を教えてください。 現状のマクロ Sub 行政回答修正あり() Dim TargetFile As String Dim fPath As String, fname As String Dim newfName As String newfName = ThisWorkbook.Sheets("Webコメント").Range("V1").Value & ".pdf" newfName = NGNarrowToWide(newfName) ''メッセージを表示し、実施確認する。 If MsgBox(newfName & vbCrLf & vbCrLf & "行政回答(修正あり)を作成しますか。", vbExclamation + vbOKCancel) <> vbOK Then Exit Sub ' ファイルのパスを指定 fPath = ThisWorkbook.Path ' ダイアログを表示してファイルを選択 TargetFile = Application.GetOpenFilename("PDFファイル ,*.pdf", , "ファイルを選択", , False) If TargetFile = "False" Then Exit Sub ' ファイル名を変更 If TargetFile = fPath & "\" & newfName Then MsgBox "同名ファイルを選択しています" Exit Sub End If If Not Dir(fPath & "\" & newfName) <> "" Then Name TargetFile As fPath & "\" & newfName Else Dim rc As Integer rc = MsgBox("既に存在する名前です" & vbCrLf & "はいを押すと既存ファイルは削除され" & vbCrLf & "リネームファイルに置き換えられます", 52, "置き換え確認") If rc = vbYes Then Application.DisplayAlerts = False Kill fPath & "\" & newfName Name TargetFile As fPath & "\" & newfName Application.DisplayAlerts = True Else MsgBox "処理を中止しました" End If End If End Sub Public Function NGNarrowToWide(ByVal stg As String) As String stg = Replace(Replace(Replace(Replace(stg, "\", "¥"), "/", "/"), ":", ":"), "*", "*") stg = Replace(Replace(Replace(Replace(stg, "?", "?"), "<", "<"), ">", ">"), "|", "|") stg = Replace(stg, """", Chr(&H8168)) NGNarrowToWide = stg End Function
質問日時: 2024/10/22 09:41 質問者: エクセル小僧
ベストアンサー
2
0
-
10
エクセルのVBAコードについて教えてください。
作業ブックの「ThisWorkbook」に 下記のコードを設定しております。 このコードは「昇降機【青紙】(表面)」の指定セル「R20」に不特定の文字が表示されないと、警告文が表示され「昇降機質疑」シートに移動できないように設定したコードです。 このコードを 指定セル「R20」に不特定の文字では無く 不特定の半角英数字(8文字)が表示されないとシート移動が出来ないように変更出来る方法を教えてください。 現状のコード Private Sub Workbook_SheetDeactivate(ByVal Sh As Object) If ActiveSheet.Name <> "昇降機質疑" Then Exit Sub Dim ws As Worksheet: Set ws = Worksheets("昇降機【青紙】(表面)") Dim c As Range If Not c Is Nothing Or IsEmpty(ws.Range("R20")) Or IsNumeric(ws.Range("R20")) Then MsgBox "未入力セルがあります、入力しないとシートを移動できません", vbCritical Application.EnableEvents = False Sh.Select Application.EnableEvents = True End If End Sub 以上となります。 宜しくお願い致します
質問日時: 2024/10/16 15:52 質問者: エクセル小僧
ベストアンサー
1
0
-
11
エクセルvbaの対象セルに色をつける 例えば a日付 b種類 c値段 dその他 にんじん 50 ぴー
エクセルvbaの対象セルに色をつける 例えば a日付 b種類 c値段 dその他 にんじん 50 ぴーまん 100 にんにく 250 ピーマン 150 みたいな表があって [やりたい事] B列の種類にピーマン、C列に100円があれば AからD列セルを黄色に B列がピーマン C列が150円は 赤色にしたい場合はどうすればいいですか? 自分なりに調べたらB列:B列で[ピーマン]の場所を検索して(dir)色をつけるみたいなことが書いてありましたがよく意味がわかりませんでした
質問日時: 2024/10/15 14:33 質問者: pico1234567
ベストアンサー
1
1
-
12
エクセルVBAのブックを開く方法 例えば [20241001] [20241002] [202410
エクセルVBAのブックを開く方法 例えば [20241001] [20241002] [20241003]のように毎日フォルダーが出来てきまして、各フォルダの中にはその日のデータが入った データA.csv データB.csv データC.csvの3つのcsvが入ってます。 マクロが入ったブックを日毎にフォルダーに入れて、 そのフォルダー内のcsvを開き、名前をつけてエクセルブックで保存したいのですがどうしたらいいですか? 困っている事 毎日フォルダが変わるのでパスでは出来ないです。出来ればデータ名は毎回同じなので、[フォルダー内のデータA.csv]を開くという設定にして、名前で拾いたい。また保存も同じファイル内にしたいです ブック[マクロ]→ファイル内のcsvを名前で開く→名前をつけてエクセルデータで同じフォルダ内に保存
質問日時: 2024/10/11 22:13 質問者: pico1234567
ベストアンサー
3
0
-
13
エクセルVBAで特定のセルの値をコメントに置き換えることについて A1のセルに入っている値(文字)を
エクセルVBAで特定のセルの値をコメントに置き換えることについて A1のセルに入っている値(文字)を、 別のシートのB1セルのコメントに貼り付けたいです。 A1の値は毎回変わるので、 マクロボタンを押すたびにA1の値を別シートB1のコメントに貼り付けるにはどうしたらいいですか? 別シートのB1のコメント欄を出す事と常に表示させる所までは出来ました。A1の値を空欄のコメントに貼り付けたいです ※何度か頑張ってみたのですが出来ず困っています。
質問日時: 2024/10/11 20:00 質問者: pico1234567
ベストアンサー
3
0
-
14
[Excel VBA]特定の条件で文字を削除&残す処理をするファイルを作成したいです
助けてください。 Excelは関数を少し使ってるくらいのVB全くわかってないレベルで恐縮なのですが 仕事で以下のファイルを作る必要があり 検索などで色々調べているものの見事につまづいております。 作りたいファイルは、添付画像のように 列Fの結合セルにはテキストで "あいうえお" が それぞれ入っているのですが メモ下の結合セル内が 〇の時は列F4の結合セル、あいうえお(赤字)を削除して空白に。 ×の時は列F11の結合セル、あいうえお(青字)はそのまま残す。 のようなマクロを組みたいです。 if分を使えば、、というイメージはありますが、型の指定など 諸々ちんぷんかんぷんでどのようにすればよいか苦慮しております。 可能であればコードをそのまま貼り付けられる状態で 教えていただけると嬉しいです。 よろしくお願いいたします。
質問日時: 2024/09/30 12:09 質問者: モノルル
ベストアンサー
4
0
-
15
【VBA】値を変更しながら連続でPDFを作成し,それらに印刷設定をした状態で結合するコード
office365を使っている者です。 以前,この掲示板でExcel VBAで連続でPDFを作製し,それらを結合した状態でPDFで出力するコードを以下のとおり教えていただいた者です。 結合する前のデータ1件につき1ページでPDFが作成されるように設定を加えたいと思い,質問させていただきます。 -------------------------------------------------------------- Sub 連続PDF作成() Dim stK, stY, stD Dim startN, endN, i As Long Const AA = "A1:H40" ' ← コピー(転記)対象のセル範囲 Const fileName = "hoge" ' ← 作成するPDFファイル名 Set stK = Worksheets("回答") Set stY = Worksheets("様式") startN = stK.Range("I2").Value endN = stK.Range("I3").Value If Application.CountBlank(stK.Range("I2:I3")) > 0 Or _ Not (IsNumeric(startN) And IsNumeric(endN)) Then _ MsgBox "無効な入力です": Exit Sub Application.ScreenUpdating = False Application.DisplayAlerts = False stY.Copy With ActiveWorkbook Set stD = ActiveSheet For i = startN To endN stK.Range("A5").Value = stK.Cells(i + 9, 1).Value stD.Copy after:=.Worksheets(.Worksheets.Count) .Worksheets(.Worksheets.Count).Range(AA).Value = stY.Range(AA).Value Next i stD.Delete .ExportAsFixedFormat xlTypePDF, ThisWorkbook.Path & "\" & fileName .Close False End With Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub ------------------------------------------------------------------------ 「様式」シートの内容を新しいシートとしてコピーして,値だけにして,それを順番に結合していくという内容になっています。「様式」シート1件のデータ(変数 i でコントロールしています)につき1ページでPDFを作成したいのですが,上のコードだと端末の環境によっては2ページになってしまうことがあります。 そこで,以下のようにPageSetupのコードを「stD.Copy after:=.Worksheets(.Worksheets.Count) .Worksheets(.Worksheets.Count).Range(AA).Value = stY.Range(AA).Value」と「Next i」の間に入れてみたのですが,デバックで止まってしまいます。(実行時エラー「438」です) どのようにすれば,問題なく動くようになるのかご教示願います。 --------------------------------------------------------------------- .Worksheets(.Worksheets.Count).Range(AA).Value = stY.Range(AA).Value .Worksheets(.Worksheets.Count).PageSetup .Worksheets(.Worksheets.Count).Zoom = False '拡大/縮小の指定を無しにする .Worksheets(.Worksheets.Count).FitToPagesWide = 1 '1ページに収める(横) .Worksheets(.Worksheets.Count).FitToPagesTall = 1 '1ページに収める(縦) .Worksheets(.Worksheets.Count).CenterHorizontally = True '真ん中に配置(横) .Worksheets(.Worksheets.Count).CenterVertically = True '真ん中に配置(縦) Next i --------------------------------------------------------------------------
質問日時: 2024/09/26 15:34 質問者: qazxcvfr4
ベストアンサー
1
0
-
16
エクセル タブの下のメニューを選択 実行するコード
エクセルのタブを選択するところまでは出来ました。 参照URL https://www.239-programing.com/cgi-bin/excelvba_bbs.cgi?id=1267#google_vignette これは 32Bit 適宜 64に変更する必要あり タブの下(そも、タブの下・これは何と呼ぶのか? 一応メニューと言うはず・・・) メニューの 左から2番目を 実行させたい ここにたどり着いたのですが https://liclog.net/menu-operation-rpa-function-vba-api/#google_vignette いまいち、こちらの能力不足で エクセル 開発 VBA 起動で 結構ですので実行コード もしくは 上記のページについて 解説願えれば幸いです。
質問日時: 2024/09/24 20:16 質問者: kozo2004
解決済
1
1
-
17
Web画面の文字をVB6で取得したい
VB6でWebブラウザを使わず(つまりIE.Navigateをぜず)に、 Web画面の文字を取得したいのですが、 どのようなコードを書けばよいでしょうか。 ひとまずxmlHTTP オブジェクトをクリエイトしての文字列取得には成功したのですが、 こちらは xmlHTTP.Open "GET", "取得したいURL" と言う命令の方法になっており、 この方法だと、Web画面の一部の文字をクリックすることで、 別画面としてポップアップされる子画面の文字は取得が無理そうでした。 それは子画面が、"取得したいURL"ではなく別ものになるからです。 では 子画面のURLはわかるので Open "GET", "子画面のURL" とするといけそうですが、親画面から起動した子画面でないと、 命令を認識しないと言う制約があるようでした。 別な表現をしますと、欲しい文字が子画面の文字なのですが、 別のURLとなっている為に取得できず、では、 xmlHTTP.Open "GET", "子画面のURL" としても、 親画面から何かを継続して表示したものでなければ、取得できない構造でした。 これはVB6のインターネットコントロールを使っても同様です。 Web画面のタイトル部分ならば、 GetWindowTextと言うAPI関数で取得できたのですが、 メイン画面から別に起動する子画面の全ての文字取得は、 実装ができませんでした。実装できる関数に心当たりはありませんか? かくなる上はセンドキーで、Ctrl+A と Ctrl+C を送るのですが、 常にターゲットの画面にフォーカスを与えなくてはならず、 他のアプリの画面が使えなくなってしまいます。 VBドットネットであればこれらは解決できるでしょうか。 ドットネットを使ってもメインのURL画面から別URLで開く、 子画面の文字列取得は難しいように思っています。 取得のためのAPI関数が分かれば一番良いのですが、 アドバイスの程、よろしくお願いします。
質問日時: 2024/09/20 11:18 質問者: VT250F
ベストアンサー
3
1
-
18
エクセルのマクロについて教えてください。
下記のマクロを実行すると、確認メッセージが表示され「YES」をクリックすると マクロ設定ブックと同じフォルダ内にある指定の圧縮ファイルを削除できます。 このコードを変更して マクロ設定ブックと同じフォルダ内に既に圧縮ファイルが削除されて無い場合に マクロを実行した時に確認メッセージが表示されない方法を教えてください。 現状のマクロ Sub 削除() Dim alert As VbMsgBoxResult alert = MsgBox("圧縮ファイルを削除してよろしいですか?", vbYesNo + vbQuestion, "削除確認") If alert <> vbYes Then Exit Sub End If On Error Resume Next Kill ThisWorkbook.Path & "\*.zip" Kill ThisWorkbook.Path & "\*.7z" End Sub 以上となります。 よろしくお願いいたします。
質問日時: 2024/09/13 11:10 質問者: エクセル小僧
ベストアンサー
4
0
-
19
エクセルのマクロについて教えてください。
下記のマクロは先ほど教えて頂いたマクロで コピー元の指定シートとセル値をコピー先にコピペできます。 Sub Macro1() Call 採光シートコピー範囲 Call 貼り付け Call 採光データ削除 End Sub 張り付けた後に コピー元のファイルが不要の為、マクロ「採光データ削除」を実行して、ファイルを削除したいのですが、削除対象のファイルが開いた状態なので、エラーメッセージが出て、ファイルを削除できません。 以前教えて頂いたコードをそのまま利用しており、コピー元のファイルのコピー範囲が完了するとこのファイルは閉じると思うのですが、なぜか、開いたままの状態です。 それぞれのマクロを書き込みますので、解決方法を教えてください。 Sub 採光シートコピー範囲() Dim folderPath As String Dim fileName As String Dim ws As Worksheet folderPath = ThisWorkbook.Path & "\" '作業フォルダ内にはマクロを設定しているコピー先のブックとコピー元の ' 採光計算確認.xlsxの 2つ のExcelファイルしかありません。 fileName = Dir(folderPath & "*.xlsx?") Do While fileName <> "" If CheckName(fileName) = True Then Exit Do fileName = Dir() Loop If fileName <> "" Then '別ブック 採光計算書.xlsx Set Wb2 = Workbooks.Open(folderPath & fileName) On Error Resume Next Set ws = Wb2.Worksheets("Table 2") If Err.Number <> 0 Then MsgBox "コピー元ブックの提出シートが見つかりません" On Error GoTo 0 Wb2.Close False End End If 'セルの値を取得する ws.Range("A1:W51").Copy On Error GoTo 0 ws.Activate ws.Range("A1:W51").Copy Else MsgBox "コピー元ブックが見つかりません": End End If End Sub Private Function CheckName(ByVal fileName As String) As Boolean CheckName = False If fileName = ThisWorkbook.Name Then Exit Function CheckName = True If LCase(Right(fileName, 5)) = ".xlsx" Then Exit Function If LCase(Right(fileName, 5)) = ".xlsm" Then Exit Function CheckName = False End Function Sub 貼り付け() Dim ws1 As Worksheet Set Wb1 = Workbooks(1) 'このブック On Error Resume Next Set ws1 = Wb1.Worksheets("採光確認") If Err.Number <> 0 Then MsgBox "コピー先ブックの受付シートが見つかりません" Application.CutCopyMode = False On Error GoTo 0 If Not Wb2 Is Nothing Then Wb2.Close False End End If Application.DisplayAlerts = False Application.EnableEvents = False ws1.Range("A1:W52").PasteSpecial Paste:=xlPasteValuesAndNumberFormats Application.CutCopyMode = False Application.EnableEvents = True Application.DisplayAlerts = True End Sub Sub 採光データ削除() Dim filePath As String filePath = ThisWorkbook.Path & "\採光計算書.xlsx" If Dir(filePath) <> "" Then Kill filePath End If End Sub 以上となります。 よろしくお願いいたします。
質問日時: 2024/09/12 12:10 質問者: エクセル小僧
ベストアンサー
6
0
-
20
エクセルのマクロについて教えてください。
下記のマクロを実行すると コピー元のシートの指定セル範囲を、コピー元(マクロ設定ブック)にコピーできます。 コピー元のシートが「Table 1」「Table 2」「Table 3」が3つあり シートを「Table 2」と指定しているのですが、上手くコピペできません、 コピー元のシート「Table 1」と「Table 3」をあらかじめ削除し、「Table 2」のみの状態で、マクロを実行すると、上手く行きます。 出来ればコピー元のシートが「Table 1」「Table 2」「Table 3」3つある状態で上手くコピペ出来る方法を教えてください。 現状のマクロです。 Sub Macro1() Call 採光シートコピー範囲 Call 貼り付け End Sub Sub 採光シートコピー範囲() Dim folderPath As String Dim fileName As String Dim ws As Worksheet folderPath = ThisWorkbook.Path & "\" '作業フォルダ内にはマクロを設定しているコピー先のブックとコピー元の ' 採光計算確認.xlsxの 2つ のExcelファイルしかありません。 fileName = Dir(folderPath & "*.xlsx?") Do While fileName <> "" If CheckName(fileName) = True Then Exit Do fileName = Dir() Loop If fileName <> "" Then '別ブック 採光計算書.xlsx Set Wb2 = Workbooks.Open(folderPath & fileName) On Error Resume Next Set ws = Wb2.Worksheets("Table 2") If Err.Number <> 0 Then MsgBox "コピー元ブックの提出シートが見つかりません" On Error GoTo 0 Wb2.Close False End End If 'セルの値を取得する ws.Range("A1:W51").Copy Else MsgBox "コピー元ブックが見つかりません": End End If End Sub Private Function CheckName(ByVal fileName As String) As Boolean CheckName = False If fileName = ThisWorkbook.Name Then Exit Function CheckName = True If LCase(Right(fileName, 5)) = ".xlsx" Then Exit Function If LCase(Right(fileName, 5)) = ".xlsm" Then Exit Function CheckName = False End Function Sub 貼り付け() Dim ws1 As Worksheet Set Wb1 = Workbooks(1) 'このブック On Error Resume Next Set ws1 = Wb1.Worksheets("採光確認") If Err.Number <> 0 Then MsgBox "コピー先ブックの受付シートが見つかりません" Application.CutCopyMode = False On Error GoTo 0 If Not Wb2 Is Nothing Then Wb2.Close False End End If Application.DisplayAlerts = False Application.EnableEvents = False ws1.Range("A1:W52").PasteSpecial Paste:=xlPasteValuesAndNumberFormats Application.CutCopyMode = False Application.EnableEvents = True Application.DisplayAlerts = True End Sub 以上となります。 よろしくお願いいたします。
質問日時: 2024/09/12 10:09 質問者: エクセル小僧
ベストアンサー
1
0
-
21
エクセルのマクロについて教えてください。
下記のマクロを実行すると、 指定フォルダ内の指定ファイルが削除できます。 この指定フォルダをマクロを設定しているフォルダ内に削除ファイルがある時に 指定ファイルを削除出来る方法を教えてください。 ilePath = "\\nas-sp01\share\確認部\電子申請 関連\2.審査中\北海\採光確認\採光計算書.pdf" このコードを マクロ設定ブックと同じフォルダ内に削除ファイルがある場合に 指定ファイルを削除したいです。 現状のマクロ Sub PDFファイル削除() Dim filePath As String filePath = "\\nas-sp01\share\確認部\電子申請 関連\2.審査中\北海\採光確認\採光計算書.pdf" If Dir(filePath) <> "" Then Kill filePath End If End Sub 以上となります。 よろしくお願いいたします。
質問日時: 2024/09/12 09:32 質問者: エクセル小僧
ベストアンサー
2
0
-
22
EXCEL vbaでシート上に配置したボタンの移動については
シート上に配置したボタンが、マウスでスクロールすると画面と共に移動し、画面表示から外れてしまいます。 この状態を、マウスで行を多く送ってもボタンは常に画面上の同じ位置にあるようにしたいのです。 コントロールの書式設定のプロパティのチェック変更では対応出来ないようです。 どなたかご存知の方、対処法をご教授ぐださいませ。よろしくお願いします。
質問日時: 2024/09/11 23:16 質問者: take913
ベストアンサー
2
0
-
23
エクセルのマクロについて教えてください。
下記マクロは先ほど教えて頂いたマクロを少し変更して 指定セル値の合計をそれぞれ セル「Y8=B4、E4・Y14=B10、E10・Y20=B16、E16中間省略Y116=B112、E112・Y122=B118、E118」に表示出来るようにしましたが、 マクロを実行すると 上記の全てのセルに Y8の計算結果が表示されてしまいます。 解決方法を教えてください。 現状のマクロ Sub Macro1() Dim i As Long Dim r As Long Dim str1 As String Dim str2 As String Sheets("Table 2").Select For i = 1 To 20 r = i * 6 + 2 str1 = "$Y$" & r str2 = "=IFERROR(ROUND(SUMPRODUCT(--TEXTSPLIT($B$4,,CHAR(10)),--TEXTSPLIT($E$4,,CHAR(10))),2),"""")" Range(str1) = str2 Next End Sub 以上となります。 よろしくお願いいたします。
質問日時: 2024/09/10 13:14 質問者: エクセル小僧
ベストアンサー
3
0
-
24
エクセルのマクロについて教えてください。
下記マクロを短いコード(一つのコード)に変更する方法を教えてください。 Sub 採光面積() Sheets("Table 2").Select Range("$AC$8").Formula = "=IFERROR(ROUNDUP($Y$8*数式! $C$1,2),"""")" Range("$AC$14").Formula = "=IFERROR(round($Y$14*数式! $C$2,2),"""")" Range("$AC$20").Formula = "=IFERROR(round($Y$20*数式! $C$3,2),"""")" Range("$AC$26").Formula = "=IFERROR(round($Y$26*数式! $C$4,2),"""")" Range("$AC$32").Formula = "=IFERROR(round($Y$32*数式! $C$5,2),"""")" Range("$AC$38").Formula = "=IFERROR(round($Y$38*数式! $C$6,2),"""")" Range("$AC$44").Formula = "=IFERROR(round($Y$44*数式! $C$7,2),"""")" Range("$AC$50").Formula = "=IFERROR(round($Y$50*数式! $C$8,2),"""")" Range("$AC$56").Formula = "=IFERROR(round($Y$56*数式! $C$9,2),"""")" Range("$AC$62").Formula = "=IFERROR(round($Y$62*数式! $C$10,2),"""")" Range("$AC$68").Formula = "=IFERROR(round($Y$68*数式! $C$11,2),"""")" Range("$AC$74").Formula = "=IFERROR(round($Y$74*数式! $C$12,2),"""")" Range("$AC$80").Formula = "=IFERROR(round($Y$80*数式! $C$13,2),"""")" Range("$AC$86").Formula = "=IFERROR(round($Y$86*数式! $C$14,2),"""")" Range("$AC$92").Formula = "=IFERROR(round($Y$92*数式! $C$15,2),"""")" Range("$AC$98").Formula = "=IFERROR(round($Y$98*数式! $C$16,2),"""")" Range("$AC$104").Formula = "=IFERROR(round($Y$104*数式! $C$17,2),"""")" Range("$AC$110").Formula = "=IFERROR(round($Y$110*数式! $C$18,2),"""")" Range("$AC$116").Formula = "=IFERROR(round($Y$116*数式! $C$19,2),"""")" Range("$AC$122").Formula = "=IFERROR(round($Y$122*数式! $C$20,2),"""")" Sheets("Table 2").Select Range("X2").Select End Sub 以上となります。 宜しくお願い致します。
質問日時: 2024/09/10 08:27 質問者: エクセル小僧
ベストアンサー
4
0
-
25
エクセルのマクロついて教えてください。
下記のマクロは先日教えて頂いたマクロです。 指定シートの指定セル範囲指定数式をコピーできます。 コードの str2 = "=IFERROR(ROUNDDOWN(($O$" & i & "+$P$" & i & "),3),"""")" 部分を =IFERROR(ROUNDDOWN(MIN(6*($O$4/$Q$4)-1.4,3),3),"3") に変更する方法を教えてください。 尚、($O$4/$Q$4)の部分はO4及びQ4から4行づつで121まで 以上になります。 よろしくお願いいたします。
質問日時: 2024/09/09 16:10 質問者: エクセル小僧
ベストアンサー
2
0
-
26
エクセルのマクロについて教えてください。
下記のマクロは指定シートの指定セル値に指定文字をコピーできます。 指定シート名「Table 2」 指定セル値「X$9」に指定文字「結 果」 このコードの内、指定セル値「X$9」を6行づつ 例えば「X$9」「X$15」「X$21」~「X$123」までの指定セルに変更出来る方法を教えてください。 現状のマクロ Sub 文字をコピー() Sheets("Table 2").Select Range("X$9").Select ActiveCell.FormulaR1C1 = "結 果" End Sub 以上となります。 よろしくお願いいたします。
質問日時: 2024/09/09 09:33 質問者: エクセル小僧
ベストアンサー
2
0
-
27
エクセルのマクロについて教えてください。
下記のマクロコードをもう少し簡素化できる方法があれば教えてください。 指定シート名「Table 2」で指定セルに指定計算式をコピーできます。 現状のマクロ Sub 水平距離() Sheets("Table 2").Select Range("$Z$4").Formula = "=IFERROR(ROUNDDOWN(($O$4+$P$4),3),"""")" Range("$Z$5").Formula = "=IFERROR(ROUNDDOWN(($O$5+$P$5),3),"""")" Range("$Z$6").Formula = "=IFERROR(ROUNDDOWN(($O$6+$P$6),3),"""")" Range("$Z$7").Formula = "=IFERROR(ROUNDDOWN(($O$7+$P$7),3),"""")" Range("$Z$10").Formula = "=IFERROR(ROUNDDOWN(($O$10+$P$10),3),"""")" Range("$Z$11").Formula = "=IFERROR(ROUNDDOWN(($O$11+$P$11),3),"""")" Range("$Z$12").Formula = "=IFERROR(ROUNDDOWN(($O$12+$P$12),3),"""")" Range("$Z$13").Formula = "=IFERROR(ROUNDDOWN(($O$13+$P$13),3),"""")" Range("$Z$16").Formula = "=IFERROR(ROUNDDOWN(($O$16+$P$16),3),"""")" Range("$Z$17").Formula = "=IFERROR(ROUNDDOWN(($O$17+$P$17),3),"""")" Range("$Z$18").Formula = "=IFERROR(ROUNDDOWN(($O$18+$P$18),3),"""")" Range("$Z$19").Formula = "=IFERROR(ROUNDDOWN(($O$19+$P$19),3),"""")" Range("$Z$22").Formula = "=IFERROR(ROUNDDOWN(($O$22+$P$22),3),"""")" Range("$Z$23").Formula = "=IFERROR(ROUNDDOWN(($O$23+$P$23),3),"""")" Range("$Z$24").Formula = "=IFERROR(ROUNDDOWN(($O$24+$P$24),3),"""")" Range("$Z$25").Formula = "=IFERROR(ROUNDDOWN(($O$25+$P$25),3),"""")" 文字数の関係上途中省略 Range("$Z$118").Formula = "=IFERROR(ROUNDDOWN(($O$118$+P$118),3),"""")" Range("$Z$119").Formula = "=IFERROR(ROUNDDOWN(($O$119+$P$119),3),"""")" Range("$Z$120").Formula = "=IFERROR(ROUNDDOWN(($O$120+$P$120),3),"""")" Range("$Z$121").Formula = "=IFERROR(ROUNDDOWN(($O$121+$P$121),3),"""")" End Sub 以上となります。よろしくお願いいたします。
質問日時: 2024/09/09 08:40 質問者: エクセル小僧
ベストアンサー
4
0
-
28
vba 別ブックに転記
OSはwin11 エクセルはoffice365です。 ご指導をいただきたいのは、 下記の参考、 1の最終行の値を、2の最終行の次の行に転記です。 条件 ※列幅 A~H ※1、2のブックは並列にウィドウズに表示 ※参照図のように転記 ※ブック2のA列は、mm/aa(aaa) 参考 1 ブック名 2024 外国為替 / シート名 Data /A B C D E F H列 ※4行目の値、若しくは入力された最終行の値を2に転記 ※ パス "C:\Users\04524\デスクトップ\keep\2024 外国為替.xlsm" 2 ブック名 2024 株価情報 / シート名 為替 /A B C D E F H列 ※4行目の値、若しくは入力された値の最終行の次の行に1からの値を転記 ※ パス "C:\Users\04524\デスクトップ\keep\2024 株価取得.xlsm" 宜しくお願いします。
質問日時: 2024/09/09 06:05 質問者: chabindora
ベストアンサー
5
0
-
29
エクセルのマクロについて教えてください。
下記のマクロは以前教えて頂いたマクロで、 マクロを実行すると、指定フォルダ内の指定ブックの指定シートを作業ブックのシートにコピーできます。 コードの「\★" & Sheets("受付・名簿・工事名・日付").Range("F2").Value & "採光計算書.xlsx")」 この部分ですが、このマクロを設定した時は、コピー元のファイル名が変更になるので、 上記のコードとしてました。 しかし、今回はファイル名「採光計算書.xlsx」が固定できますので、 「\★" & Sheets("受付・名簿・工事名・日付").Range("F2")」このコードは不要となります。 ファイル名を固定したマクロに変更出来る方法を教えてください。 現状のマクロ Sub シートコピー() Dim myPath As String myPath = ThisWorkbook.Path With Workbooks.Open("\\nas-sp01\share\確認部\■意匠\戸建\★" & Sheets("受付・名簿・工事名・日付").Range("F2").Value & "採光計算書.xlsx") .Worksheets("Table 2").Cells.Copy ThisWorkbook.Worksheets("Table 2").Cells(1, 1) .Close False End With End Sub 以上となります。 宜しくお願い致します。
質問日時: 2024/09/05 12:57 質問者: エクセル小僧
ベストアンサー
3
0
-
30
エクセルのマクロについて教えてください。
下記のマクロを実行すると、指定したPDFファイルのオリジナル名(元々のファイル)の後ろに 指定セル値「V1」の値がプラスされて、PDF名が変更になります。 例えば「12345678-5北海 太郎.pdf」がオリジナル名 「V1」に「_9月5日(交付用)」とあった場合には マクロを実行すると 「12345678-5北海 太郎_9月5日(交付用).pdfと変更されます。 このマクロですと、マクロ設定ブックのフォルダ内に変更されたPDFファイルが保存されてしまいます。 元のPDFファイル(オリジナル)が保存されているフォルダ内に変更されたPDFファイルを保存出来る方法を教えてください。 現状のマクロ Sub 交付用名前変更() Dim TargetFile As String Dim fPath As String, fname As String Dim newfName As String newfName = ThisWorkbook.Sheets("管理表").Range("V1").Value & ".pdf" newfName = NGNarrowToWide(newfName) ''メッセージを表示し、実施確認する。 If MsgBox(newfName & vbCrLf & vbCrLf & "(交付用)を作成しますか。", vbExclamation + vbOKCancel) <> vbOK Then Exit Sub ' ファイルのパスを指定 fPath = ThisWorkbook.Path ' ダイアログを表示してファイルを選択 TargetFile = Application.GetOpenFilename("PDFファイル ,*.pdf", , "ファイルを選択", , False) If TargetFile = "False" Then Exit Sub newfName = CreateObject("Scripting.FileSystemObject").GetBaseName(TargetFile) & newfName If Dir(fPath & "\" & newfName) = "" Then Name TargetFile As fPath & "\" & newfName Else Dim rc As Integer rc = MsgBox("既に存在する名前です" & vbCrLf & "はいを押すと既存ファイルは削除され" & vbCrLf & "リネームファイルに置き換えられます", vbExclamation + vbYesNo, "置き換え確認") If rc = vbYes Then Kill fPath & "\" & newfName Name TargetFile As fPath & "\" & newfName Else MsgBox "処理を中止しました" End If End If End Sub Public Function NGNarrowToWide(ByVal stg As String) As String stg = Replace(Replace(Replace(Replace(stg, "\", "¥"), "/", "/"), ":", ":"), "*", "*") stg = Replace(Replace(Replace(Replace(stg, "?", "?"), "<", "<"), ">", ">"), "|", "|") stg = Replace(stg, """", Chr(&H8168)) NGNarrowToWide = stg End Function 以上となります。 よろしくお願いいたします。
質問日時: 2024/09/05 09:24 質問者: エクセル小僧
ベストアンサー
1
0
-
31
VBA コードどこがおかしいですか?
ExcelでC2からデータが縦に5つずつ入力されています。 そのデータをG列(G1から開始)に横にデータをはりつけたいのですがどこがおかしいでしょうか? 添付画像は、実行した結果こうしたいという意味ではりつけてます。 エラーになる個所は Cells(i, Q + 7) = myList(Z, 1) ' G列からK列にコピーです 全体コード↓↓ Sub 縦リストを横リストに変換() Dim i As Long Dim Q As Long Dim Z As Long Dim lastRow As Long Dim myList As Variant ' C列のデータを配列に格納 myList = Range("C2", Range("C" & Rows.Count).End(xlUp)) ' 最終行を取得 lastRow = Cells(Rows.Count, 3).End(xlUp).Row Z = 1 ' 列をループ For i = 1 To lastRow / 5 ' 配列を5つ分ループ For Q = 0 To 4 Cells(i, Q + 7) = myList(Z, 1) ' G列からK列にコピー Z = Z + 1 Next Q Next i End Sub
質問日時: 2024/08/29 16:07 質問者: mihomiho34
ベストアンサー
3
1
-
32
VBA初心者です。次のVBAコードで、17行目を削除したいのですがうまく動きません 改善策を教えてく
VBA初心者です。次のVBAコードで、17行目を削除したいのですがうまく動きません 改善策を教えてください。 debug.printで確認した感じX17の値を取得できていないような感じもします。 sub test() if range("X7").value="false" then rows(17).delete end if end sub
質問日時: 2024/08/28 09:37 質問者: 中山あ
ベストアンサー
3
0
-
33
Vba UserformからExcelシートのサイズ変更について教えてください
いつもお世話になります 今、UserFormからExcelシートのサイズが変更できなくて悩んでいます。 本来のプログラムはUserFormからInputBoxで最小にしてあるシートのデータを 参照するときにそのシートのサイズを最大にしたいのですが、上手くできません。 下記のサンプルプログラムは質問用に作りました。 UserForm1を呼び出す前にシートのサイズを最小にして、 UserFirm1で最大にしているだけですが、出来ていません (Sample) Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Boolean Declare PtrSafe Sub SetForegroundWindow Lib "user32" (ByVal hwnd As LongPtr) Sub test() '...ユーザフォームのクラス名を指定 FormClassName = "ThunderDFrame" '...ウィンドウのハンドルを取得 hwnd = FindWindow(FormClassName, vbNullString) '...表示(最小化されている場合は、これがないと表示状態になりません) check = ShowWindow(hwnd, 3) '...最前面表示 SetForegroundWindow hwnd VBA.AppActivate Excel.Application.Caption Application.WindowState = xlMinimized UserForm1.Show End Sub (UserForm1) Private Sub UserForm_Activate() UserForm1.Top = 100 UserForm1.Left = 600 VBA.AppActivate Excel.Application.Caption Application.WindowState = xlMaximized End Sub もし良い方法があれば教えてください 以上、よろしくお願い申しあげます
質問日時: 2024/08/19 18:19 質問者: 公共ごま
ベストアンサー
1
0
-
34
pdfファイルの複数添付 引数の型
vbaでメール送信時にpdfファイルを2つ添付したいのですが ファイル名の指定でエラーが出てしまいます。 色々やってみたのですが、現在byref引数の型が一致しませんという エラーが出ていて進まなくなりました。 教えてください。お願いします。 Sub sendMail_withattach() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("mail") Dim OutApp As Outlook.Application Set OutApp = New Outlook.Application Dim r As Long, lastrow As Long lastrow = ws.Cells(4, 1).End(xlDown).Row For r = 4 To lastrow Dim OutMail As Outlook.MailItem Set OutMail = OutApp.CreateItem(olMailItem) Dim attachFile As Outlook.Attachments Set attachFile = OutMail.Attachments Dim attachFile2 As Outlook.Attachments Set attachFile2 = OutMail.Attachments Dim BodyOfMail As String BodyOfMail = CreateBodyOfMail(ws, r) With OutMail .SendUsingAccount = Session.Accounts("aaa@bbb.com") .To = ws.Cells(r, 3).Value .Subject = ws.Cells(2, 5).Value .body = BodyOfMail End With Dim key As String key = ws.Cells(2, 11).Value Dim key2 As String key2 = ws.Cells(2, 11).Value Call AddAttach(attachFile, key) Call AddAttach(attachFile2, key2) OutMail.Display ' OutMail.Save OutMail.Send Set OutMail = Nothing Next r End Sub Sub AddAttach(attachFile As Object, attachFile2 As Object, key As String, key2 As String) Dim filename As String Dim filename2 As String Dim 案内 As String Dim チラシ As String filename = Dir(ThisWorkbook.Path & "\pdf\" & 案内 & "*") attachFile.Add ThisWorkbook.Path & "\pdf\" & filename filename2 = Dir(ThisWorkbook.Path & "\pdf\" & チラシ & "*") attachFile2.Add ThisWorkbook.Path & "\pdf\" & filename2 MsgBox filename & vbCrLf & filename2 Set attachFile = Nothing End Sub よろしくお願いいたします
質問日時: 2024/08/18 08:47 質問者: vba_miyuki
ベストアンサー
3
0
-
35
Excel_VBAについて質疑です。(for~next)
お世話になります。 1つのブックに「sheet1」と「sheet2」があります。 sheet1=転記元 (20名分のデータ) sheet2=転記先 名前1 sheet1のセルB2:B14を → sheet2のセルE・F10:E・F22に転記 (sheet2のE・Fはセル結合) sheet1のセルB16:B18を → sheet2のセルE・F23:E・F25に転記 ( 〃 ) sheet1のセルB19を → sheet2のセルE・F27に転記 ( 〃 ) sheet1のセルB20を → sheet2のセルE・F31に転記 ( 〃 ) 名前2 sheet1のセルC2:C14を → sheet2のセルM・N10:M・N22に転記 (sheet2のM・Nはセル結合) sheet1のセルC16:C18を → sheet2のセルM・N23:M・N25に転記 ( 〃 ) sheet1のセルC19を → sheet2のセルM・N27に転記 ( 〃 ) sheet1のセルC20を → sheet2のセルM・N31に転記 ( 〃 ) 名前3 sheet1のセルD2:D14を → sheet2のセルU・V10:U・V22に転記 (sheet2のU・Vはセル結合) sheet1のセルD16:D18を → sheet2のセルU・V23:U・V25に転記 ( 〃 ) sheet1のセルD19を → sheet2のセルU・V27に転記 ( 〃 ) sheet1のセルD20を → sheet2のセルU・V31に転記 ( 〃 ) 20名分のデータを転記(for~next ループ)させたいと思います。 VBAコードをご教示いただけますと幸いです。 宜しくお願い致します。
質問日時: 2024/08/16 18:47 質問者: ちえのしつもん
ベストアンサー
4
0
-
36
ExcelVBAマクロで実行した時の疑問
NAS内のフォルダ内に置いたExcelVBAを実行した時の疑問です。 そのフォルダは、ファイルの削除やリネームが出来ない権限設定にしています。 マクロはそのファイルだ内にCSV出力したり出力ファイルのリネーム等をさせたりしているのですが、 許可されていない権限のユーザがそのExcelを開いてマクロを実行すると、ファイル操作が問題なくできました。 マクロが行うファイル操作というのは、NASから見た時実行したユーザがファイル操作をした事と同じとは見なされないんでしょうかね? 細かい話ですみません。
質問日時: 2024/08/08 10:25 質問者: tanapyondai
解決済
2
0
-
37
VBAの間違い教えて下さい
このvbaどこが間違ってるでしょうか?条件合ってる気がするのですが指定ファイルがないと出ます。 Excelファイル名 ・ZAX0278A-11_4U07_MG-001486KED_20240727_OK ・C1セル;ZAX0278A-11 ・F1セル;4U07 ・A6セル以降;1486KED Sub SearchAndListFiles() Dim ws As Worksheet Dim outputWs As Worksheet Dim folderPath As String Dim searchPattern As String Dim fileName As String Dim folderName As String Dim filePath As String Dim cell As Range Dim searchStr As String Dim baseFolder As String Dim formattedCellValue As String ' シートの設定 Set ws = ThisWorkbook.Sheets("Sheet1") Set outputWs = ThisWorkbook.Sheets("出荷時設定") ' セルの値を取得 Dim C1 As String, F1 As String C1 = ws.Range("C1").Value F1 = ws.Range("F1").Value ' C1に基づいて検索するフォルダーを決定 If C1 = "ZAX0278A-11" Then folderName = "ハンファ" ElseIf C1 = "ZAX0277A-11" Then folderName = "汎用" Else MsgBox "C1セルの値が無効です。" Exit Sub End If ' ベースフォルダーパスを設定(必要に応じてベースパスを調整) baseFolder = "C:\BaseFolder\" & folderName & "\" ' A列の6行目から下のセルをループ For Each cell In ws.Range("A6:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row) ' A列のセル値を6桁になるように変換 formattedCellValue = Format(Mid(cell.Value, 1, Len(cell.Value) - 3), "000000") & Right(cell.Value, 3) ' 検索パターンを生成 searchPattern = "*" & C1 & "_" & F1 & "_*-" & formattedCellValue & "*OK*.xlsx" ' パターンに一致するファイルを検索 fileName = Dir(baseFolder & searchPattern) ' ファイルが見つかった場合 If fileName <> "" Then Do While fileName <> "" ' 見つかったファイル名を「出荷時設定」シートに書き込む outputWs.Cells(outputWs.Cells(outputWs.Rows.Count, "A").End(xlUp).Row + 1, 1).Value = fileName ' 次のファイル名を取得 fileName = Dir() Loop Else MsgBox "ファイルが見つかりませんでした: " & searchPattern End If Next cell MsgBox "検索が完了しました。" End Sub
質問日時: 2024/08/03 21:35 質問者: ケイ0000
解決済
5
1
-
38
vbs ブック共有を解除
vbsでドラッグアンドドロップしたExcelファイルのブック共有解除 ActiveWorkbook.UnprotectSharing ActiveWorkbook.ExclusiveAccess を行いたいのですがうまくいきません ご教示いただけますと幸いです。 ▼ VBScriptを使ってExcelファイルを開き、共有を解除 ' エラーハンドリングを有効にする On Error Resume Next ' Excelアプリケーションオブジェクトを作成する Set objExcel = CreateObject("Excel.Application") ' Excelアプリケーションの警告を表示しないように設定 objExcel.DisplayAlerts = False ' コマンドライン引数(ドラッグアンドドロップ)からファイルパスを取得 Set objArgs = WScript.Arguments If objArgs.Count = 0 Then ' Excelアプリケーションを終了し、オブジェクトを解放 objExcel.Quit Set objExcel = Nothing WScript.Quit End If filePath = objArgs(0) ' ファイルが存在するか確認 If CreateObject("Scripting.FileSystemObject").FileExists(filePath) Then ' Excelファイルを開く ' 共有を解除 Set objWorkbook = objExcel.Workbooks.Open(filePath) ActiveWorkbook.UnprotectSharing ' ワークブックを閉じる objWorkbook.Close False End If ' Excelアプリケーションを完全に終了する objExcel.Quit Set objWorkbook = Nothing Set objExcel = Nothing ' エラーハンドリングを解除 On Error GoTo 0
質問日時: 2024/07/28 03:25 質問者: 名無しの受験生
解決済
2
0
-
39
Vba TextBox1.ControlSourceについて教えてください
いつもお世話になります 今、Userformにおいて テキストボックスに値またはリンク先アドレスの入力を併用できないか考えています リンク先のアドレス入力は On Error Resume Next Set Target = Application.InputBox("「柱の高さ」データセルを選択", Left:=500, Top:=100, Type:=8) If Err.Number > 0 Or Target.Address = "" Then '..キャンセル時、また入力無し Exit Sub End If On Error GoTo 0 Targetadd = Target.Address(False, False) TargetWS = Target.Worksheet.Name TextBox4.Enabled = False '...TextBox4.ControlSourceにセットした後にTextBox4の値を手動でクリアするとExcelシートの値が消えるので編集不可にした With TextBox4 .ControlSource = TargetWS & "!" & Targetadd End With としていますが Application.InputBoxに直接、数値を入力したときもそのままValueとして 扱える方法はあるのものですか? 以上、いつも変な質問ばかりですみませんが 分かりましたら教えてください
質問日時: 2024/07/26 15:36 質問者: 公共ごま
ベストアンサー
3
0
-
40
サブフォルダに格納されているファイルを、ファイル名ごとに条件分岐させたい
お世話になっております。 当方VBA初心者のため、ご教示ください。 張りつけするファイル(xlsx)と同フォルダ内に「Voltから始まるファイル(CSV)」と「Currから始まるファイル(CSV)」が大量にサブフォルダに格納されています。 Voltの時とCurrの時ではりつける場所を変えるマクロが知りたいです。 また、グラフの作成(範囲の修正)もしたいです。 ①開くサブフォルダを指定する (調べていて見つけたのが、ダイアログボックスでフォルダを指定するタイプでした。) ②Voltの時、C5~C135に入力されている数値をコピー、別ファイルのAK6に貼り付ける ファイルごとに最終列の隣へどんどん貼り付けていく ③ファイルごとに数字を追加 フォルダが変わると数字を1~にする ※1フォルダにVolt5個、Curr5個程度(どちらもたまに6個)入っています。 2行目にフォルダの日付、3行目に1~、4行目に1回目~5回目(たまに6回目)と記載したい 3行目のフォルダ数は日付によって違います。 ④貼り付ける前でも後でも良いのですが、1行ごとに空白行を挿入する 例)AK141:0.365 AK142:空白 AK143:0.412 ⑤折れ線グラフの作成 貼り付けた6行目と141行目の1行を折れ線グラフにする(空白行は飛ばしてすべての行を128個作成) グラフについては、すでにAJ列まで作成済みのものがありますので、可能であれば追加した列分の範囲の修正を行いたいです。 上記のことがしたいのですが、初心者なため、サンプルコードをいただけるとありがたいです。 また、マクロで再現が難しいということがあればご教示願います。 お手数をおかけしますが、よろしくお願いいたします。
質問日時: 2024/07/22 10:36 質問者: maaaaatam
解決済
1
0
-
41
IF文、条件分岐の整理方法
プログラミング初学者です。 添付画像の条件分岐を簡潔なコードにしたいです。 IF文のみで記述しようとしましたがもっと簡単に考えることができるのでは無いかと思っています。 丸々コードにして頂かなくて結構ですので 関数としてコードをわける、戻り値を使用するなど 考え方だけでもアドバイスいただければ幸いです。
質問日時: 2024/07/19 21:21 質問者: mmmmo777
ベストアンサー
6
1
-
42
VBAコードのインデント表示
Visual Basic(VBA)のカテゴリーにマクロコード付きの質問が投稿されますが、Webブラウザで見るとインデント表示されなくて見る気がしません。スマホアプリで見るとインデントされていますが、画面が小さいので辛いです。改善方法はあるでしょうか?
質問日時: 2024/07/18 14:13 質問者: いんちょ
ベストアンサー
2
0
-
43
時間短縮のために、テキストファイルの入出力をメモリを使って出来ないですか?
いつもお世話になります 今、400行のデータをExcelからScriptファイルを使ってAutoCadに出力しています その際、ファイルは保存形式UTF-8で Set stm = New ADODB.Stream stm.Charset = "UTF-8" stm.LineSeparator = adLF としています データ列は13列、一行づつScriptファイルを作りAtuoCadに送ります For Row = 1 To GridRows '...行のループ stm.Open '...ファイルオープン For Col = 1 To GridCols '...列のループ With CellInfo(Row, Col) '...セル情報 If .Text <> "" Then moji1 = CStr(.TextX) & "," & CStr(.TextY) '出力座標値 moji2 = CStr(TextHeight) '文字サイズ moji3 ="0.0" '文字出力角度 strRec = "-Text" & vbCrLf & opt & vbCrLf & moji1 & vbCrLf & _ moji2 & vbCrLf & moji3 & vbCrLf & .Text stm.WriteText strRec, 1 '...ファイル書き出し End If End With Next Col Application.Wait [Now() + "00:00:00.2"] '...0.2秒待つ stm.SaveToFile PLTFname, 2 '...ファイル保存 stm.Close '...ファイルを閉じる Application.Wait [Now() + "00:00:00.1"] '...0.1秒待つ SendKeys "script" & Chr(13) & PLTFname & Chr(13) '...Scriptファイルの実行 Application.Wait [Now() + "00:00:00.1"] '...0.1秒待つ Next Row '(原点は選択セルの左上としています) AutocadにScriptコマンドを送るときには前後に0.1秒 stmファイル書き出しには、「出力エラーが」が出るため0.1秒から0.2秒待たせます この小さな時間が積み重なって、結構な時間になります 0.2秒待ちで、3分12秒 0.1秒待ちで、2分27秒 目標はあと1分短縮させたいのですが、stmの出力先にメモリを使えないかと相談しました 以上、良いご回答を期待しています よろしくお願い申し上げます
質問日時: 2024/07/13 15:33 質問者: 公共ごま
ベストアンサー
7
1
-
44
エクセルのマクロについて教えてください。
下記のマクロを実行すると作業ブックのセル値がAccessの指定セル値にコピーできます。 このコードの内「 rs.Fields("備考欄") = ws.Range("E29").Value」ですが セルの書式設定で「"希望日"m/d"急ぎ";@」と設定しているのですが、 実行するとAccessの(備考欄)には:日付のみがコピーされております。 書式設定したように「希望日7/5急ぎ」をコピー出来る方法を教えてください。 現状のマクロ Sub 昇降機管理表() alert = MsgBox("Accessにデータ移動してよろしいですか?", vbYesNo + vbQuestion, "Access確認") If alert <> vbYes Then Exit Sub End If Dim ws As Worksheet: Set ws = Worksheets("基本情報") Dim db As String: db = "\\nas-sp01\share\新・確認申請管理表.accdb" Dim cn As Object: Set cn = CreateObject("ADODB.Connection") cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & db & ";" Dim rs As Object: Set rs = CreateObject("ADODB.Recordset") rs.Open "確認申請(建築物)", cn, 1, 3 rs.AddNew 'rs.Fields("ID") = ws.Range("A1").Value rs.Fields("受付NO(ERI)") = ws.Range("F17").Value rs.Fields("物件名") = ws.Range("AJ4").Value rs.Fields("正受付日") = ws.Range("D29").Value rs.Fields("確認予定日") = ws.Range("D30").Value rs.Fields("意匠法定通知(送付)") = ws.Range("D31").Value rs.Fields("市町村名") = ws.Range("C8").Value rs.Fields("代理人") = ws.Range("C4").Value rs.Fields("主要用途") = ws.Range("AH2").Value rs.Fields("ERI担当") = ws.Range("D16").Value rs.Fields("備考欄") = ws.Range("E29").Value rs.Update rs.Close cn.Close End Sub 以上となります。 宜しくお願い致します。
質問日時: 2024/07/05 10:32 質問者: エクセル小僧
ベストアンサー
1
0
-
45
ワードVBA どの表か知ることはできますか
ワードで、表がいくつかあるのですが、現在のカーソルがどのセルにあるか知ることはできますか。
質問日時: 2024/07/05 10:19 質問者: payphone
ベストアンサー
1
0
-
46
エクセルのマクロについて教えてください。
下記のマクロを実行すると セル「H5」をセル「L2」にコピペできます。 マクロを実行した時にセル「L2」に不特定の文字が先に表示されているときに このマクロを実行しても「L2」に上書きされない方法があれば教えてください。 現状のマクロ Sheets("受付").Range("L2").Value _ = Sheets("受付").Range("H5").Value End Sub 以上となります。 宜しくお願い致します。
質問日時: 2024/07/04 16:21 質問者: エクセル小僧
ベストアンサー
1
0
-
47
エクセルのVBAコードについて教えてください。
マクロ設定ブックのThisWorkbookに下記のコードを設定しております。 作業ブックをオープンしたタイミングで、「マクロ:提出シートコピー削除」が実行できますが、 この作業が完了した後、別ブック名「物件毎のファイル名.xlsm」 に保存後、違う作業に移行しますが、別ブックに保存した、ブックをオープンすると、又、「マクロ:提出シートコピー削除」が実行されてしまいます。 ThisWorkbookに設定したコードを一度だけ実行できる方法又は、最初のマクロ有効ブックのファイル名「総合引き受け(戸建て).xlsm」(ファイル名は固定です)の時だけ実行でき、ファイル名が変更後は、コードが実行されない方法があれば教えてください。 現状のコード Private Sub Workbook_Open() Dim alert As VbMsgBoxResult alert = MsgBox("提出シートを貼り付けますか?", vbYesNo + vbQuestion, "貼り付け確認") If alert <> vbYes Then Exit Sub End If Call 提出シートコピー削除 End Sub 以上となります。 よろしくお願いいたします。
質問日時: 2024/07/04 10:13 質問者: エクセル小僧
ベストアンサー
2
0
-
48
エクセルのマクロについて教えてください。
下記のマクロは先日教えて頂いたマクロで、マクロを実行すると 同じ作業フォルダ内にある別ブック(拡張子が.xlsx)を開きコピー範囲を指定出来るようになっております。 稀に、(拡張子が.xlsm)の場合もあり、拡張子が(.xlsx又は.xlsm)の両方に対応できるように変更出来る方法があれば教えてください。 尚、フォルダ内には、作業ブック(マクロ設定ブック)とコピー元のExcelファイル2つしかありません。 よろしくお願いいたします。 現状のマクロ Sub 提出シートコピー範囲() Dim folderPath As String Dim fileName As String Dim ws As Worksheet folderPath = ThisWorkbook.Path & "\" '作業フォルダ内にはマクロを設定しているコピー先のブックとコピー元の '○〇(提出用).xlsxの 2つ のExcelファイルしかありません。 fileName = Dir(folderPath & "*.xlsx") If fileName <> "" Then '別ブック ○〇(提出用).xlsx Set Wb2 = Workbooks.Open(folderPath & fileName) On Error Resume Next Set ws = Wb2.Worksheets("提出シート") If Err.Number <> 0 Then MsgBox "コピー元ブックの提出シートが見つかりません" On Error GoTo 0 Wb2.Close False End End If 'セルの値を取得する ws.Range("B1:H47").Copy Else MsgBox "コピー元ブックが見つかりません": End End If End Sub よろしくお願いいたします。
質問日時: 2024/07/04 08:52 質問者: エクセル小僧
ベストアンサー
3
0
-
49
エクセルのVBAコードについて教えてください。
下記のコードは先日教えて頂いたコードを参考に作成しました。 セルD47に不特定の文字が表示されるとマクロ住所コピーが実行されます。 しかし、セルD47があるシートを他のブックのシートからコピペした場合は マクロが上手く実行されません。 セルD47に直接書き込むとマクロが事項されます。 この問題を解決できる方法を教えてください。 よろしくお願いいたします。 If Not Intersect(Range("$D$47"), Target) Is Nothing And Not Target.Value <> "" Then Call 住所コピー 以上となります。 よろしくお願いいたします。
質問日時: 2024/07/03 17:47 質問者: エクセル小僧
ベストアンサー
1
0
-
50
エクセルのマクロについて教えてください。
下記のマクロは先日教えて頂いたマクロで、 マクロを実行すると、ワイルドカードで指定したブックを開く事が出来ます。 ファイル名 ①22069167-1_00-確認申請受付【花子】(提出用).xlsx の場合は上手くマクロが実行されてブックを開く事が出来ますが。 ②210610132-1_東二条7丁目住宅新築工事【太郎】(提出用) .xlsx の場合は"コピー元ブックが見つかりません"を表示されてブックを開く事が出来ません。 下記のコードを変更し、①の場合も②の場合も両方ブックを開く事が出来る方法があれば教えてください。 よろしくお願いいたします。 現状のマクロ Sub 提出シートを開く() Dim folderPath As String Dim fileName As String folderPath = ThisWorkbook.Path & "\" fileName = Dir(folderPath & "*(提出用).xlsx") Do While fileName <> "" Workbooks.Open (folderPath & fileName) fileName = Dir() Loop End Sub Sub 提出シートコピー範囲() Dim ws As Worksheet If Workbooks.Count > 1 Then Set Wb2 = Workbooks(2) '別ブック On Error Resume Next Set ws = Wb2.Worksheets("提出シート") If Err.Number <> 0 Then MsgBox "コピー元ブックの提出シートが見つかりません" On Error GoTo 0 Wb2.Close False End End If 'セルの値を取得する ws.Range("B1:H47").Copy Else MsgBox "コピー元ブックが見つかりません": End End If End Sub 以上となります。 よろしくお願いいたします。
質問日時: 2024/07/03 09:22 質問者: エクセル小僧
ベストアンサー
7
0
【Visual Basic(VBA)】 に関する回答募集中の質問
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
【Visual Basic(VBA)】に関するコラム/記事
-
弁護士が語る「合法と違法を分けるオンラインカジノのシンプルな線引き」
「お金を賭けたら違法です」ーーこう答えたのは富士見坂法律事務所の井上義之弁護士。オンラインカジノが違法となるかどうかの基準は、このように非常にシンプルである。しかし2025年にはいって、違法賭博事件が相次...
-
釣りと密漁の違いは?知らなかったでは済まされない?事前にできることは?
知らなかったでは済まされないのが法律の世界であるが、全てを知ってから何かをするには少々手間がかかるし、最悪始めることすらできずに終わってしまうこともあり得る。教えてgooでも「釣りと密漁の境目はどこです...
-
カスハラとクレームの違いは?カスハラの法的責任は?企業がとるべき対応は?
東京都が、客からの迷惑行為などを称した「カスタマーハラスメント」、いわゆる「カスハラ」の防止を目的とした条例を、全国で初めて成立させた。条例に罰則はなく、2025年4月1日から施行される。 この動きは自治体...
-
なぜ批判コメントをするの?その心理と向き合い方をカウンセラーにきいた!
今や生活に必要不可欠となったインターネット。手軽に情報を得られるだけでなく、ネットを介したコミュニケーションも一般的となった。それと同時に顕在化しているのが、他者に対する辛らつな意見だ。ネットニュース...
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
VBAでCOPYを繰り返すと、処理が途中...
-
【マクロ】並び替えの範囲が、その...
-
【マクロ】オートフィルター を非表...
-
Vba Array関数について教えてください
-
Vba 型が一致しません(エラー13)...
-
【ExcelVBA】値を変更しながら連続...
-
vbsでのwebフォームへの入力制限?
-
エクセルのマクロについて教えてく...
-
【ExcelVBA】5万行以上のデータ比...
-
VBAでセルの書式を変えずに文字列を...
-
【マクロ】開いているブックの名前...
-
Vba セルの4辺について罫線が有るか...
-
vb.net(vs2022)のtextboxのデザイン...
-
Excel VBA 選択範囲の罫線色の変更...
-
【マクロ】売上一覧YYYYMMDDHHSS.xl...
-
エクセルの改行について
-
VBAで特定の文字が入った行をコピー...
-
WindowsのOutlook を VBA から操作する
-
Excel 範囲指定スクショについて Ex...
-
【マクロ】シートの変数へ入れるコ...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
Vba セルの4辺について罫線が有るか...
-
vbsでのwebフォームへの入力制限?
-
【ExcelVBA】5万行以上のデータ比...
-
【マクロ】売上一覧YYYYMMDDHHSS.xl...
-
【マクロ】開いているブックの名前...
-
【マクロ】並び替えの範囲が、その...
-
エクセルの改行について
-
エクセルのマクロについて教えてく...
-
vb.net(vs2022)のtextboxのデザイン...
-
VBAでCOPYを繰り返すと、処理が途中...
-
VBA ユーザーフォーム ボタンクリッ...
-
エクセルのVBAコードと数式について...
-
エクセルのVBAコードについて教えて...
-
[VB.net] ボタン(Flat)のEnable時の...
-
【マクロ】変数を使った、文字の種...
-
改行文字「vbCrLf」とは
-
質問58753 このコードでうまく動作...
-
【マクロ】シートの変数へ入れるコ...
-
ワードの図形にマクロを登録できる...
-
算術演算子「¥」の意味について
おすすめ情報