常連

### 実現したいこと
Excel VBAを用いて、同じ文面のメールをリスト化された複数のアドレスと宛名を取得し送信したいです。
メール本文の中の、会社名や宛名を個別に置き換えたいです。
※ネットで拾ったコードを使わせてもらっています

### 発生している問題・分からないこと
マクロを実行すると、
「実行時エラー'62': ファイルにこれ以上データがありません。」
というエラー出て、一件しかメールを送信できません。

### エラーメッセージ
```error
実行時エラー'62': ファイルにこれ以上データがありません。
```

### 該当のソースコード

```
'プログラム0｜変数宣言の指定
Option Explicit
 
'プログラム1｜プログラム開始
Sub SendMails()
 
    'プログラム2｜変数設定
    Dim mailaddress As String
    Dim subject As String, mailbody As String
    Dim username As String, tsuchi As String
    Dim ws As Worksheet
    Dim cmax As Long
    Dim i As Long
    Dim txtfile As String, txtpath As String, attachedfile As String
    Dim txt As TextStream
    
    'プログラム3｜FileSystemObjectの設定
    Dim fs As Scripting.FileSystemObject
    Set fs = New Scripting.FileSystemObject
      
    'プログラム4｜テキストファイルの情報の取得
    txtfile = "【パソコンスキルの教科書】登録ありがとうございます.txt"
    txtpath = ThisWorkbook.Path & "\" & txtfile
    Set txt = fs.OpenTextFile(Filename:=txtpath, IOMode:=ForReading)
      
    'プログラム5｜メール件名の取得
    subject = Split(txtfile, ".")(0)
      
    'プログラム6｜添付ファイルを取得
    attachedfile = ThisWorkbook.Path & "\添付ファイル.jpg"
      
    'プログラム7｜ワークシート設定
    Set ws = Worksheets("メールリスト")
 
    'プログラム8｜各シートの記載情報を取得
    cmax = ws.Range("A65536").End(xlUp).Row
              
    'プログラム9｜Outlookメール送信用の変数設定
    Dim OutlookObj As outlook.Application
    Dim myMail As outlook.MailItem
    Set OutlookObj = CreateObject("Outlook.Application")
 
    'プログラム10｜シート「メールリスト」の情報を取得
    For i = 2 To cmax
        
        'プログラム11｜F列のON/OFFでメール通知設定を決定
        tsuchi = ws.Range("E" & i).Value
        If tsuchi = "ON" Then
        
            'プログラム12｜メール本文とメールアドレスを取得
            username = ws.Range("C" & i).Value
            mailbody = Replace(txt.ReadAll, "{名前}", username)
            mailaddress = ws.Range("D" & i).Value
            
            'プログラム13｜Outlookメールを作成
            Set myMail = OutlookObj.CreateItem(olMailItem)
            
            'プログラム14｜メール内容を設定
            myMail.BodyFormat = 3
            myMail.To = mailaddress
            myMail.CC = "fastclassinfo@gmail.com"
            myMail.subject = subject
            myMail.Body = mailbody
    
            'プログラム15｜添付ファイルがあればメールに添付
            If attachedfile <> "" Then
                myMail.Attachments.Add (attachedfile)
            End If
            
            'プログラム16｜メール送信
            myMail.Display 'メール表示(ここでは誤送信を防ぐために表示だけにして､メール送信はしない)
            myMail.Send 'ここをコメントアウトすることでメール送信しないことも可能
            ws.Range("F" & i).Value = "送信完了：" & Now()
            
            'プログラム17｜オブジェクト解放
            Set myMail = Nothing
        End If
    Next
    Set OutlookObj = Nothing
 
'プログラム18｜プログラム終了
End Sub
```

### 試したこと・調べたこと
- [x] teratailやGoogle等で検索した
- [x] ソースコードを自分なりに変更した
- [ ] 知人に聞いた
- [ ] その他

##### 上記の詳細・結果
teratailで同様の質問を見つけましたが、回答を見てもどのように修正すればいいかわからず、再度質問を上げさせていただいています。

### 補足
https://teratail.com/questions/370887（過去の同様のご質問）

VBAで複数Outlookメールを個別作成し一斉送信

古いDBからExcelVBAでExcelにレコードを書き込むツールを作ってみたのですが、かなり重く悪戦苦闘しています。

現場のプロのみなさんはどう対応されてるかお伺いしたいです。

【状況】
2005年に作成されたAccess2000形式の拡張子「.mdb」のデータベースで、再構築した方が早そうなのは重々承知なのですが、他部署の営業が使ってるということでDBの再構築が叶わない状況です。
※Accessは32bitの2019版。win10の32bit。共有ドライブ上での使用。
※自身は1部署の効率化ツールを作成するために派遣で常駐しています

【ExcelVBA実行時の状況】
・初回の実行が4，5分かかります。しかし、2回目以降は数秒で該当のレコードをExcelシートに書き出すことができます。

・上記はaccessを開いた状態です。開いていないと、2回目以降も遅いです。アクセスを開いてクエリ実行完了までに5分くらいかかります。

【なぜ、実行準備が整うまで時間がかかるツールを使うのか】
2回目以降は数秒で取得できるため、処理件数（Excelのリストシート）が多いほど手動でやるよりも早く終わるからです。
※該当の顧客レコードを取得し、整形・加工して印刷とPDF保存を行うツールです

【ExcelVBA側のドライバ】
AIに聞いたところ、12.0の方がいいよってことなので、それを使ってます。
AI「Microsoft.Jet.OLEDB.4.0 は公式にはサポート終了しているため、可能であれば Microsoft.ACE.OLEDB.12.0 を使うのが推奨されます。
32bit 環境でも、Access Database Engine 2010 (32bit版) をインストールすれば、以下のように ACE.OLEDB.12.0 を使うことができます。」

【やってみたこと】
DBの最適化のみ（無駄クエリ、無駄テーブル等の削除行為は他部署のツールだからできない）

【DBの様態】
実際にデータが入っているDBと、フォームがあるDB（リンクテーブル）は分割されている

【知りたいこと】
経験豊富なプロの方たちはもし上記の状況だった場合、どうされますか？？
この状況は詰んでいますでしょうか？
これ以上やりようが無いか確かめたく質問させていただきました。

【上記の状況を要約】
勝手にDB再構築できない、レポートのレイアウトや、フォームの機能変更はできない。レコードを取得するのみならず更新作業もある。でも、事務作業に時間とられたくないから何とかならないかという依頼を受けている。




20年前に作られた古いAccessDBについて

AccessのVBAからExcelを開いて指定行を固定する操作をしたいです。

```ACCESS
   Dim ExcelApp As Object
   Dim ExcelBook As Object

   Set ExcelApp = CreateObject("excel.application")
   ExcelApp.Visible = True
   Set ExcelBook = ExcelApp.Workbooks.Open(StrFile)

 ExcelBook.Worksheets("Sheet1").Activate
   range("C2").Select
   ActiveWindow.FreezePanes = True
   ExcelBook.Save
   ExcelBook.Close
   ExcelApp.Quit
   Set ExcelBook = Nothing
   Set ExcelApp = Nothing
```
（関係ないコードは省きました）

「range("C2").Select」の行でエラーが起こっており、要するにRangeがうまくセレクトできないという意味だと思います。
このエラーでググって試行錯誤しましたがどうにもよくわかりませんでした。
実行すると表題のエラーが出るときと出ないときがあり、解決方法が見いだせない状況です。

よろしくお願いします。

実行時エラー"1004"「"Range"メソッドは失敗しました："_Global"オブジェクト」

### 実現したいこと
VBS実行時の警告を無視したい

### 発生している問題・分からないこと
VBSおよびExcelVBAに関する質問です。
下記のVBSを実行するとき、「B.xlsm」が他の端末で開いたままだと、"B.xlsmは編集のためロックされています"というような警告が表示されます。
この際、下記のようなことは可能でしょうか？
・案①：読み取り専用で開く
・案②："B.xlsmは編集のためロックされています"というような警告が表示される場合、VBSのxlApp.Run "OpenBFile"をSKIPするといったことはできますでしょうか？

### エラーメッセージ
```error
"B.xlsmは編集のためロックされています"
```

### 該当のソースコード

```VBS
Dim xlApp, xlBook

' Excelを起動
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True

' Excelファイルを開く（パスは適宜変更）
Set xlBook = xlApp.Workbooks.Open("C:\パス\A.xlsm")

' マクロを実行
xlApp.Run "OpenBFile"

' Excelを終了
xlApp.Quit
```

```VBA
Sub OpenBFile()
    Workbooks.Open Filename:="B.xlsm"
End Sub
```

### 試したこと・調べたこと
- [x] teratailやGoogle等で検索した
- [ ] ソースコードを自分なりに変更した
- [ ] 知人に聞いた
- [ ] その他

##### 上記の詳細・結果
VBAの下記の前にエラーハンドリングを設定しても、VBSを実行すると同様の警告が出てきてしまいます。
    Workbooks.Open Filename:="B.xlsm"


### 補足
"VBS" , "VBA"

VBSでExcelVBAにて対象ファイルを開くときに警告が出てくる

### 実現したいこと
![イメージ説明](https://ddjkaamml8q8x.cloudfront.net/questions/2025-04-23/7f0f9e60-9917-45a5-8624-97d63df276fd.png)

大項目ごとの合計数字を代入したい。該当する列に。
添付の画像の①30行目と②40行目のカテゴリー別の合計行に、①には、23行目と29行目の小項目の合計を、②には、33行目と39行目の小項目の合計を該当する列に代入したい。
小項目の合計だけをうまく取得して、カテゴリー別の合計行に代入できないかと考えています。


### 発生している問題・分からないこと
![イメージ説明](https://ddjkaamml8q8x.cloudfront.net/questions/2025-04-23/74a84326-37e7-49c5-b30d-b46257bc37c2.png)

＜困っていること＞
合計する行は固定の行ではないので、「合計」という文字列のある行を取得して、合計するようにしていますが、
①だけならうまくいくのですが、
②の合計を算出する際に、①の下の行からカウントしなければならないのですが（1行目からだと二重計上になるため）、それがうまくいきません。
なぜか、②の行には0が代入されてしまいます。



### 該当のソースコード

```
※試しに以下のコードで一つの列で合計値を出したのですが、問題なく算出され代入されます。

Sub CalculateSpecificSum()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim sumRow As Long
    Dim totalSum As Double
    Dim currentRow As Long
    
    ' シートを指定
    Set ws = ThisWorkbook.Sheets("収益状況")
    
    ' 合計値を初期化
    totalSum = 0
    
    ' A列の最初の「合計」行を取得
    sumRow = ws.Columns("A").Find(What:="合計", LookAt:=xlPart, MatchCase:=False).Row

    ' A列の「合計」行までループ
    For currentRow = 6 To sumRow - 1 ' 合計行の直前まで
        ' B列が「合計」の場合のみ処理
        If ws.Cells(currentRow, "B").value Like "*合計*" Then
            ' 12列目（L列）の値を加算
            totalSum = totalSum + ws.Cells(currentRow, 12).value
        End If
    Next currentRow

    ' 合計値をA列の「合計」行のL列に代入
    ws.Cells(sumRow, 12).value = totalSum
    
    MsgBox "指定された合計の計算が完了しました！", vbInformation
End Sub


※以下は、各列ごとに合計値を算出するようにしているはずなのですが、0となり算出されません。

Sub ProcessRevenueSums()
    Dim ws As Worksheet
    Dim sumRow As Long
    Dim totalSum As Double
    Dim currentRow As Long
    Dim colIndex As Variant
    Dim sumColumns As Variant
    
    ' シートを指定
    Set ws = ThisWorkbook.Sheets("収益状況")
    
    ' 合計する列を指定
    sumColumns = Array(12, 13, 14, 18, 19, 20, 21, 24, 25, 26, 27, 28, 29, 30, _
                       34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48)

    ' A列の最初の「合計」行を取得
    sumRow = ws.Columns("A").Find(What:="合計", LookAt:=xlPart, MatchCase:=False).Row

    ' 各列を順次処理
    For Each colIndex In sumColumns
        ' 合計値を初期化
        totalSum = 0
        
        ' A列の「合計」行までの範囲をループ
        For currentRow = 6 To sumRow - 1 ' 合計行の直前まで
            ' B列が「合計」の場合のみ処理
            If ws.Cells(currentRow, "B").value Like "*合計*" Then
                ' 該当列の値を加算
                totalSum = totalSum + ws.Cells(currentRow, colIndex).value
            End If
        Next currentRow

        ' 合計値をA列の「合計」行に代入
        ws.Cells(sumRow, colIndex).value = totalSum
    Next colIndex
    
    MsgBox "指定された列に順次合計を代入しました！", vbInformation
End Sub
```

### 試したこと・調べたこと
- [ ] teratailやGoogle等で検索した
- [x] ソースコードを自分なりに変更した
- [ ] 知人に聞いた
- [ ] その他

##### 上記の詳細・結果
上記に記載のとおりですが、どうしてもうまくいきません。
Excelの関数でしたら実現できると思うのですが、該当する行が変わるので、その都度入力する手間もかかるため、VBAで実現できないかと考えています。
どなたか力を貸していただければ幸いです。
よろしくお願いいたします。

### 補足
特になし

VBAで、複数行あるカテゴリーごとの合計値の算出ができない

### 実現したいこと
フォルダのなかから特定の文字を含むエクセルファイルをコピーして別のフォルダに保存するためのコードを教えてください。

また、フォルダ内に階層があり、
2番目の階層のフォルダ場所が毎月変わります。
【フォルダの階層】
①「データ」フォルダ
②「2025年4月」（ここのファイル場所が対象月に変わる）
③「第一]「第二」←この中にある特定のファイルを「作業」フォルダにコピーしたい

③の「第一]「第二」フォルダに格納されているエクセルファイルのうち
”あいう”または”かきく”を含むファイルをコピーして「作業」フォルダに保存する。

あいうえお(第一).xlsx コピーして保存
かきくけこ(第二).xlsx コピーして保存
さしすせそ(第一).xlsx コピーしない


### 発生している問題・分からないこと
単純なコピーのコードしかわからず、やりたい事のコードがわかりませんでした。



### 該当のソースコード

```
特になし
```

### 試したこと・調べたこと
- [x] teratailやGoogle等で検索した
- [ ] ソースコードを自分なりに変更した
- [ ] 知人に聞いた
- [ ] その他

##### 上記の詳細・結果
同様の質問を探すことができませんでした。

### 補足
特になし

VBA　特定の値があるファイルのコピー

100行3000列ほどのエクセルデータから
キーワード＝項目 が一致する列を抽出したいです。
![![イメージ説明](92cf181d8e4e9f873c181801b3f283a6.gif)
上記のようなデータ一覧から
   A    B   C
１ 年賀状  氏名  誕生日
２
３
｜
のように、キーワードを選択して
その列に入ってる値をすべて抽出したいです。

また、元のデータ量が変動しても、抽出する
キーワードが変更しても使いやすいように
「元のデータは」セル範囲指定でなく
シート全部もしくは編集中のセル全てを対象としたいです。

キーワードは可能であれば
元のデータとは別シートに記載すると
その別シートのキーワードの列（下）に反映されるようにしたいです。

以前に投稿されていた
【マクロ】検索に一致した条件とその下のセルを抽出
を参考に作成したのですが、
検索設定を行ごとに記述が必要なため、
変動する元のデータに対応しきれませんでした。
マクロを書き換えるのはキーワードが変更になった時だけに
なるような方法で記述するにはどうすれはいいでしょうか？

ご教授のほどよろしくお願い申し上げます。

【マクロ】選択した項目の列をすべて抽出して別シートへ

VBAで書きたいです。

特定の範囲(出来れば図のような範囲、難しい場合はシート全体からでもOK)に
オレンジがあればB1セルに[A]、オレンジがない場合はB1セルに[B]と記載したい場合
どの様にコードを書いたらいいでしょうか。

こんな感じかな、と書いてみたのですが、見当違いなようで動きません。

どなたかアドバイスお願いします。

![イメージ説明](e5f26fb0f03a8b005a5862cdf6a24d72.png)

```VBA
Sub Test()
    
    Dim Flag
    
	Select Case True
		Case Range("I8:T17").Interior.ColorIndex = RGB(0、166、93)　　　　　'緑
		Case Range("I8:T17").Interior.ColorIndex = RGB(237、28、36)　　     '赤
		Case Range("I8:T17").Interior.ColorIndex = RGB(255, 255, 255)　　   '白　　
		Case Else
			Flag = False
	End Select
	
	If Flag = False Then
		Range("B2") = "〇"
	Else
		Range("B2") = "×"
	End If
		

End Sub
```