常連

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
```

VBAで特定の色がついたセルがある場合に処理をする。

### 実現したいこと
合体データフォルダ内の
1.csv
2.csv
3.csv
4.csv
の4つのファイルを結合して
同じ合体データフォルダ内に
新しいcsvで出力するというこーどを書きたい


### 発生している問題・分からないこと
今起きている事象としては

【問題①】
◾︎一回目
1-4のcsvファイルを読み込み、出力できた
◾︎二回目
合体データフォルダ内の1-4のデータは削除し、翌日新しい1-4のデータを入れ実行した所、削除したはずの前日のデータで出力された

読み込むcsvフォルダ名が1.2.3.4のまま読み込む必要があり、変更が出来ないので(こちらの事情で)、どこかでパスのリセットを行う必要があるのかと思いましたが、
何回やっても同じファイルができあがるので
わかる方にアドバイスを頂きたいです。

【問題②】
・合体データフォルダ内に出力したいのですが
1つ上のフォルダに出力されてしまいます。こちらも何度がコードを加えてみたのですが上手くいかず。
アドバイスを頂きたいです。



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

```VBA
以下コードです
(リセットするコードは一旦抜いています)

Sub csv合体()
    Dim folderPath As String
    Dim fso As Object
    Dim file As Object
    Dim textLine As String
    Dim outputFileName As String
    Dim outputFile As Integer
    Dim inputFile As Integer
    Dim firstFile As Boolean
   
    ' フォルダのパスを指定
    folderPath = "C:\temp\合体データ"
   
    ' 出力ファイル名（指定の名前で保存）
    outputFileName = folderPath & ".csv"
 
    ' ファイルシステムオブジェクトを作成
    Set fso =      CreateObject("Scripting.FileSystemObject")
   
    ' 出力ファイルを作成
    outputFile = FreeFile
    Open outputFileName For Output As #outputFile
   
    firstFile = True
   
    ' フォルダ内のCSVファイルを処理
    For Each file In fso.GetFolder(folderPath).Files
        If Right(file.Name, 4) = ".csv" Then
            inputFile = FreeFile
            Open file.Path For Input As #inputFile
           
            ' 最初のファイルのヘッダーを含める
            If firstFile Then
                firstFile = False
            Else
                ' 2つ目以降はヘッダーをスキップ
                Line Input #inputFile, textLine
            End If
           
            ' 各行を出力ファイルに書き込む
            Do While Not EOF(inputFile)
                Line Input #inputFile, textLine
                Print #outputFile, textLine
            Loop
           
            Close #inputFile
        End If
    Next file
   
    Close #outputFile
   
    MsgBox "CSVファイルの結合が完了しました！", vbInformation
End Sub
```

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

##### 上記の詳細・結果
chatGptにて3つほどコードを追加提案されましたが上手くいかず。

### 補足
特になし

CSVファイル結合のVBAで、前回の読み込んだデータが残ったままになってしまう

### 実現したいこと
Excelのマクロ機能を使用し、outlookでメール送信したいです。

### 発生している問題・分からないこと
ツール→参照設定を開いても
「microsoft outlook ●　object library」がありません。

下記エラーが出るのは、上記設定ができていないためと思っております。

### エラーメッセージ
```error
マクロを実行すると、下記エラーが発生します。

-------------------------------------------------------------
実行時エラー　429

ActiveXコンポーネントはオブジェクトを作成できません
-------------------------------------------------------------
```

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

```
Sub SendEmailWithConfirmation()
    Dim OutApp As Object
    Dim OutMail As Object
    
    ' Outlookアプリケーションを取得
    Set OutApp = CreateObject("Outlook.Application")　←実行すると、ここが黄色くなります
    Set OutMail = OutApp.CreateItem(0)
    
```

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

##### 上記の詳細・結果
https://www.sejuku.net/blog/76520

こちらの「参照設定を追加する方法」項目で追加しようとしましたが、
そもそも「MSOUTL.OLB」ファイルがなかった為、断念しました。

### 補足
OS　　：Windows11
Excel　：2021
マクロのライブラリ：Microsoft Office 16.0 Object Library
Outlook：1.2025（新しいOutlook）

Excelのマクロを用いてoutlookでメール送信したい

以下のマクロを記述しsheet上にボタンを設置しマクロを実行しようとしたのですが

なぜか、「マクロ’test’を実行できません。
このブックでマクロが使用できないか、またはすべてのマクロが無効になっている可能性があります。」と出てきます

このsheet上には他にもボタンを設置しているのですが他のマクロは問題なく動きます

また、このマクロもボタンではなくフォームの実行からだと正常に動きます

このような問題はどうすれば解決するのでしょうか？

verはexcel2016です

```

Sub test()


'セルK22～L22の範囲を切り取り、K21を基点に貼り付け

Range("K22:L22").Cut Destination:=Range("K21")

Range("K10:L21").Select
Selection.Copy



End Sub


```

マクロ’ ’を実行できません。  このブックでマクロが使用できないか、またはすべてのマクロが無効になっている可能性があります。

以下のマクロを実行すると「現状の実行結果」のように天気が実行されます。
転記元ファイルの担当者に空白があると、同開発のその下の担当者のところで処理が止まってしまいます。（空白を無しにすると正常に実行されるのは確認しています）

処理の途中で空白のセルが存在した時に、今回でいうと「実装したい実行結果」のように、その行だけをスキップして処理を継続させるようにしたいのですが、インターネットなどで調べ、以下の「該当箇所（現状のソースの一部）」でその部分を実装しようとしたのですが、なかなかうまくできないので、教えていただきたいです。

該当箇所（現状のソースの一部）
```Macro
                            '担当者が空白の時スキップする
                            If Cells(n, 3) = " " Then
                                n = n + 1
                            End If
```


現状の実行結果
![イメージ説明](bdfc4fe901e016a05f8901d3b653a789.png)

実装したい実行結果
![イメージ説明](34e0292871b15e442cc9383db9f80494.png)

転記元ファイル（質問用.xls）
![イメージ説明](3dd9c9b33a1e3e6df92e0b0daff7d37c.png)

現状のソース
```Macro
Sub sample1()

    Dim lngRowsNo       As Long                     ' 書きこむ位置
    Dim lngSheetIndex   As Long                     ' シートの番号
    Dim strFile         As String                   ' Excelファイルの場所
    Dim xlsAcq          As New Excel.Application    ' 取得側Excel
    Dim wbAcq           As Workbook                 ' 取得側Excelブック
    Dim wsAcq           As Worksheet                ' 取得側Excelシート
    Dim wsSet           As Worksheet                ' 設定側Excelシート
    Const strPath       As String = ""
    Set wsSet = ActiveSheet
    Dim i As Long

     strFile = Dir(strPath & "*.xls")
    lngRowsNo = 3
    Do Until strFile = ""
        '----- Excelブックを開く
        Set wbAcq = Workbooks.Open(strPath & strFile)

        '----- シートを検索
        For lngSheetIndex = 1 To wbAcq.Worksheets.Count
            '----- 「更新」シートを検索
            If wbAcq.Worksheets(lngSheetIndex).Name = "更新" Then
                '----- 「更新」シートを変数へ登録
                Set wsAcq = wbAcq.Worksheets(lngSheetIndex)
                '----- 「更新」シートの内容を現在のシートにコピー(自由に変更して下さい)
                With wsAcq
                Dim fname As String        'ファイル名
                Dim n As Long                  'ループで使用します。
                Dim m As Long                  'ループで使用します。
                Dim ec1 As Long               '各開発の一番下の担当者のセルを取得
                Dim ec2 As Long               '各開発の 月の一番右（最後）のセルを取得
                Dim ColumnNo As Long    ' 転記先の列番号（初期値４）
                Dim ColumnNo2 As Long    ' 転記元の列番号（初期値５）＋３されていく
                
                ColumnNo = 4
                ColumnNo2 = 5

                For i = 1 To .UsedRange.Rows.Count

                    If Left(.Cells(i, 2).Value, 2) = "開発" Then
                     '月を取得して転記
                    ec2 = .Cells(i + 1, 5).End(xlToRight).Column + 1
                    For col = 5 To ec2
                    
                        wsSet.Cells(2, ColumnNo).Value = .Cells(i + 1, ColumnNo2).Value
                        
                        ColumnNo = ColumnNo + 1
                        ColumnNo2 = ColumnNo2 + 3
                        
                    Next col

                    ' ------ 開発〇から一番上の担当者のセル位置を相対的にCells(i + 3, 3)として取得し
                     'データの入っているところまでループさせる (その時、開発名を転記)
                     ec1 = .Cells(i + 3, 3).End(xlDown).Row
                        For n = i + 3 To ec1
                        
                            'ファイル名
                            fname = ActiveWorkbook.Name
                            wsSet.Cells(lngRowsNo, 1).Value = fname
                            
                            '開発
                            wsSet.Cells(lngRowsNo, 2).Value = .Cells(i, 2).Value
                            
                             '担当者
                            wsSet.Cells(lngRowsNo, 3).Value = .Cells(n, 3).Value
                            
                            '担当者が空白の時スキップする
                            If Cells(n, 3) = "" Then
                                n = n + 1
                            End If
                            
                             '工数
                            wsSet.Cells(lngRowsNo, 4).Value = .Cells(n, 5).Value
                            
                            wsSet.Cells(lngRowsNo, 5).Value = .Cells(n, 8).Value
                            
                            wsSet.Cells(lngRowsNo, 6).Value = .Cells(n, 11).Value
                            
                            wsSet.Cells(lngRowsNo, 7).Value = .Cells(n, 14).Value
                            
                            wsSet.Cells(lngRowsNo, 8).Value = .Cells(n, 17).Value
                            
                            wsSet.Cells(lngRowsNo, 9).Value = .Cells(n, 20).Value
                            
                            wsSet.Cells(lngRowsNo, 10).Value = .Cells(n, 23).Value
                            
                            wsSet.Cells(lngRowsNo, 11).Value = .Cells(n, 26).Value
                            
                            wsSet.Cells(lngRowsNo, 12).Value = .Cells(n, 29).Value
                            
                            wsSet.Cells(lngRowsNo, 13).Value = .Cells(n, 32).Value
                            
                             '１行下へ
                            lngRowsNo = lngRowsNo + 1
                            
                        Next n
                    End If
                Next i
                End With
               
                '----- 検索の終了
                Exit For
            End If
        Next lngSheetIndex

        '----- シート参照の解放
        Set wsAcq = Nothing
        '----- ブックを閉じる
        wbAcq.Close Savechanges:=False
        '----- 次のファイルへ
        strFile = Dir()
    Loop

    '----- Excelへの参照の解放
    Set xlsAcq = Nothing

End Sub
```

VBA マクロで処理中に空白のセルが存在するときのスキップ方法

**前提・実現したいこと**
エクセルファイルを同じフォルダ内に、別名保存で保存したい。
（既存ファイルの上書き保存実施後に別名保存させようとしています。）

**発生している問題・エラーメッセージ**
エラーメッセージは特になく、
デスクトップ　または　ドキュメントフォルダに保存されてしまいます。

VBA初心者です。勉強不足で恐縮ですがよろしくお願い板います。


**該当のソースコード**
```
Dim thisPath As String

thisPath = ThisWorkbook.Path

ThisWorkbook.SaveAs Filename:=thisPath & "ファイル名.xls"

```
（不要な部分は割愛しております）

同じフォルダ内に、別名保存で保存したい。

### 前提・実現したいこと

入力フォームに、日付を入力するテキストボックスがあります。
このテキストボックスにはデフォルトで今日の日付が入っているようにしたいのです。

![作成中の入力フォーム](f70d1375f0e82263487f153270cdd1d5.png)

### 発生している問題・エラーメッセージ

テキストボックスに今日の日付が入りません。

### 該当のソースコード

```VBA
Private Sub UserForm1_Initialize()
    txtDate.Text = Date
    txtDate.Format = "Long Date"
End Sub
```

### 試したこと

以前も別の入力フォームを作ったときに、同様の実装をしているのですが、その際は
```VBA
txtDate.Text = Format(Date, "YYYY/MM/DD")
```
で実装できているので、このようにもしてみましたが、だめでした。

### 補足情報

Excel2010、Win7 64bit版で操作しています。
初心者ですので初歩的なところで躓いている気がしますが、どうぞ皆様ご教示くださいませ・・・。