常連

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で特定の色がついたセルがある場合に処理をする。

### 実現したいこと
CA列に重複がある場合、優先度判定を行い、優先度の低い重複行をすべて削除したい。
データは６千行ほどあり、VBAで処理したいです。
CB列は文字列（1.*****   2.*****）となっており、左から先頭一文字目が1~7の数字となるのでまずこれを抽出する。

優先度の判定
・CB列の数字が小さい行を優先する
・CB列の数字が同じ場合、A列の数字が大きい行を優先する


行番号　CA列　CB列
１　　　x　　　1
２　　　y　　　4
３　　　x　　　3
４　　　y　　　4
５　　　z　　　6
６　　　x　　　2

例えば上記の例だと、
行番号１・３・６がCA列重複→CB列の優先度１が最も高いので３・６行目は削除
行番号２・４がCA列重複→CB列の優先度は同じ→A列の優先度４が高いので２行目は削除
行番号５は重複なしなので残す



### 発生している問題・分からないこと
辞書機能を使って既存の行と現在の行での比較（２行分の比較）しかできず、どうやっても
３行以上の比較が分からなかったので質問しました。



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

```
特になし
```

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

##### 上記の詳細・結果
Googleでは優先度を判定する重複行削除の例が見つかりませんでした。

### 補足
特になし

【VBA】優先度を判定し重複行の削除をしたい

以下のマクロを記述し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 マクロで処理中に空白のセルが存在するときのスキップ方法

### 実現したいこと
タスクスケジューラーからテラタームマクロの実行

### 発生している問題・分からないこと
タラタームマクロをタスクスケジューラーから実行しようとしていますが、
どうしてもタスクスケジューラーから正常に実行できません。
テラタームマクロをダブルクリックで実行すると正常に実行はできておりますが、タスクスケジューラーから手動で実行しても、「実行中」とだけ表示され、ログファイルも作成されない状態です。

**※**ログオンしているかに関わらず、最高権限で実行しています。
**※**Windows10 Proで実行しようとしています。

タスクスケジューラーの履歴を見ても、エラーはありません。

以下マクロのコードとなります。

```ここに言語を入力
;==============================================
;; 接続先サーバ・ユーザ名・パスワード設定
HOSTADDR = '192.168.1.1'
USERNAME = 'testuser'
PASSWORD = 'testtest'
log_name = 'C:\scripts\test\reboot.log'
;==============================================

COMMAND = HOSTADDR
strconcat COMMAND ':23 /nossh /T=1'

connect COMMAND

logopen log_name 1 1

wait 'SV login:'
sendln USERNAME

wait 'Password:'
sendln PASSWORD

wait 'Welcome!'
wait 'SV # '

sendln 'execute reboot'

wait 'SV #'

sendln 'exit'
```

タスクスケジューラーの設定では、「操作の編集」で以下の値を入れました。

プログラム/スクリプト（P）→テラタームマクロのexeが置かれているフルパス
"C:\Program Files (x86)\teraterm\ttpmacro.exe"

引数の追加（オプション）実行するテラタームマクロ
/V C:\scripts\test\reboot-1.ttl

開始オプション（T）→テラタームマクロが設置されているフォルダ
C:\scripts\test

ご教示の程、宜しくお願い致します。



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

```
特になし
```

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

##### 上記の詳細・結果
プログラム/スクリプト（P）→テラタームマクロのexeが置かれているフルパス
"C:\Program Files (x86)\teraterm\ttpmacro.exe"

引数の追加（オプション）実行するテラタームマクロ
/V C:\scripts\test\reboot-1.ttl

開始オプション（T）→テラタームマクロが設置されているフォルダ
C:\scripts\test

上記をネットで調べ、色々変更してみましたが、解決できていません。

### 補足
特になし

teratermマクロがタスクスケジューラーから起動できない

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

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

VBAにてオートフィルターのコードを書いています。

「RangeクラスのAutoFilterメゾットが失敗しました。」
というエラーが発生していて困っています。

**やりたい内容

・ユーザーフォームのリストボックスの値を選択する（リストボックスは複数選択でき、５つ用意してある）
・それぞれのリストボックスで選択された項目をANDでオートフィルタ―かけたい**


実際のコードと、ユーザーフォーム、データシートの画像を貼り付けました。
ご参考ください。

どのようなコードにすれば実現できるでしょうか。
ご教示お願い申し上げます。![イメージ説明](dafddff9db5c5b5557f54a7f8d8029e7.png)
![イメージ説明](2bf4d3b66296cc7218e2fbd86d3390f4.png)

```vba
Dim RER() As String
   Dim r As Integer
   Dim rnt As Integer
   

For r = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(r) = True Then
            
            rnt = rnt + 1
            ReDim Preserve RER(1 To rnt)
            RER(rnt) = ListBox1.List(r)
        End If
    Next r
 
   
    
    
 '選択項目でのフィルター
'RERと同様にJER,FER,KER,GERは作成しています
 
  Dim arr As Variant
  arr = Split(Join(RER, ",") & "," & Join(JER, ",") & "," & Join(FER, ",") & "," & Join(KER, ",") & "," & Join(GER, ","), ",")
Worksheets("製品データ").Range("A1").AutoFilter Criteria1:=arr, Operator:=xlFilterValues




```