常連

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

### 実現したいこと
VBAで複数シートの情報を一つのシートに集約しようとしています。
この際、収集を除外するシートも設けています。


### 発生している問題・分からないこと
ただ収集が不規則であり、時には一番右端のシートのみ抽出します。
各シートのセルに結合箇所などはなく、
いろいろ調べてみましたがどうしても原因がわかりません。



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

```
On Error Resume Next
   Dim sh1, sh2 As Worksheet
   Dim dicT As Object
   Dim i, n,R1, R2 As Long
 
    Set sh1 = Worksheets("A")

For Each s In ThisWorkbook.Worksheets
    R1 = sh1.Cells(sh1.Rows.Count, "A").End(xlUp).Row
    R2 = s.Cells(s.Rows.Count, "B").End(xlUp).Row

    n = R1 + 1
    For i = 2 To R2
 If s.Name <> "A" And s.Name <> "B" And s.Cells(i, "B") <> "" Then


        sh1.Cells(n, "B") = s.Cells(i, "A")

              n = n + 1
       End If
    Next 
    Next
```

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

##### 上記の詳細・結果
For each ではなくシートをカウントするコードに書き換えましたが現象は変わりませんでした。

### 補足
特になし

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

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

### 実現したいこと
ガントチャートを作成しており、カレンダーの日付に合わせたサイズのテキストボックスを複数挿入するところまではうまくいったのですが、各テキストボックスの中のテキスト(文字)を変数として設定し、それぞれに挿入することがうまくいかないのでこれを実現したいと考えています。アドバイスいただけますと幸いです。

### 発生している問題・分からないこと
With .TextFrame
      .Characters.Text = x
のｘに変数として設定し、一応認識しているようですが、挿入した複数のテキストボックスすべてに最下行の文字列が挿入されております。



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

```
Sub テキストボックス()
   Application.ScreenUpdating = False
   Application.Cursor = xlWait
   Application.EnableEvents = False
   Application.DisplayAlerts = False
   Application.Calculation = xlCalculationManual
Dim sh1 As Worksheet
 Set sh1 = Worksheets("Gantt")
Dim b, S, E, i

b = sh1.Range("Q4")
For i = 7 To sh1.Cells(Rows.Count, "M").End(xlUp).row
If Cells(i, "M") <> "" And Cells(i, "N") <> "" Then
Set S = sh1.Cells(i, "Q").Offset(0, DateDiff("d", b, Cells(i, "M")))
Set E = sh1.Cells(i, "Q").Offset(0, DateDiff("d", b, Cells(i, "N")))

Call 挿入(S, E)
End If
Next
    Application.StatusBar = False
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.Cursor = xlDefault
    Application.ScreenUpdating = True
End Sub

Sub 挿入(S, E)
   Application.ScreenUpdating = False
   Application.Cursor = xlWait
   Application.EnableEvents = False
   Application.DisplayAlerts = False
   Application.Calculation = xlCalculationManual
 
 Set sh1 = Worksheets("Gantt")
Dim i As Long
 For i = 7 To sh1.Cells(Rows.Count, "B").End(xlUp).row
  x = sh1.Cells(i, "B").value
With sh1.Shapes.AddTextbox(msoTextOrientationHorizontal, S.Left, S.Top, (E.Left + E.Width) - S.Left, E.Height)
With .TextFrame
      .Characters.Text = x
      .Characters.Font.Color = RGB(0, 0, 0)
      .HorizontalAlignment = xlHAlignCenter
      .VerticalAlignment = xlVAlignCenter
    End With
   With .Fill
        .ForeColor.ObjectThemeColor = msoThemeColorAccent1
        .ForeColor.Brightness = 0.800000011
  End With
End With
Next i
    Application.StatusBar = False
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.Cursor = xlDefault
    Application.ScreenUpdating = True
End Sub


```

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

##### 上記の詳細・結果
x = sh1.Cells(i, "B").valueかｘの書く位置が悪いのではないかといろいろ変更しましたがうまくいきません。

### 補足
特になし

複数テキストボックス挿入時のテキストを変数として入力したい。

以下のマクロを実行すると「現状の実行結果」のように天気が実行されます。
転記元ファイルの担当者に空白があると、同開発のその下の担当者のところで処理が止まってしまいます。（空白を無しにすると正常に実行されるのは確認しています）

処理の途中で空白のセルが存在した時に、今回でいうと「実装したい実行結果」のように、その行だけをスキップして処理を継続させるようにしたいのですが、インターネットなどで調べ、以下の「該当箇所（現状のソースの一部）」でその部分を実装しようとしたのですが、なかなかうまくできないので、教えていただきたいです。

該当箇所（現状のソースの一部）
```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 マクロで処理中に空白のセルが存在するときのスキップ方法

### 実現したいこと
複数ページにわたる資料を指定行毎に区切って印刷する際、
すべてのページにタイトルを設定することはできたのですが、
タイトル範囲を複数設定できないかと調べています。
よく会社が外部に出す資料などにはタイトルと、ページの下段に備考欄があるフォーマットを使用していると思いますが、
これと同じようにしたいと考えています。

### 発生している問題・分からないこと
いろいろ調べているのですがやりたいことに関する情報が見つかりません。



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

```
Sub 複数タイトル設定印刷()
 Dim i As Long, er As Long, pb As Long
  Worksheets("依頼書").ResetAllPageBreaks
  pb = 10
 er = Worksheets("見積依頼書").Cells(Rows.Count, 2).End(xlUp).Row
 
 For i = pb + 16 To er Step pb
  Worksheets("依頼書").HPageBreaks.Add Before:=Worksheets("依頼書").Cells(i, 2)
 Next
 With Worksheets("依頼書")
        .PageSetup.PrintTitleRows = Range(Cells(1, 2), Cells(15, 2)).Address
        .PageSetup.PrintTitleColumns = Range(Cells(1, 2), Cells(1, 6)).Address
        .PrintOut Preview:=True
    End With
  Worksheets("依頼書").PrintPreview
End Sub


```

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

##### 上記の詳細・結果
いろいろ調べているのですがやりたいことに関する情報が見つかりません。

### 補足
特になし

VBA 複数のタイトル範囲を設定して印刷

### 実現したいこと
ファイルが壊れたと思い、バックアップ用のファイルで試してうまく動いていましたがやはり出るようになりました。
1から18列までで検索するフォームですが実際のシートは20列まであるシートです。
解決策があればアドバイスお願いします。

### 発生している問題・分からないこと
これまでずっと動いていたのですが突然オーバーフローしましたと出るようになり、
以下のところが→で警告されます。
ary_d = sh1.Range(sh1.Cells(1, 1), sh1.Cells(R1, 18)) 



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

```
 Application.ScreenUpdating = False  
    Application.Cursor = xlWait 
    Application.EnableEvents = False 
    Application.DisplayAlerts = False 
    Application.Calculation = xlCalculationManual '計算を手動に
    Dim ary_d    'セルデータ用配列
    Dim dic_d As Object     'Dictionaryオブジェクト
    Dim t_row_d As Long     '配列ary_d 処理対象行
    Dim id As Long    
    Dim ary_list    
    Dim sh1 As Worksheet
    Dim R1 As Long

Set sh1 = Worksheets("PO")
     R1 = sh1.Cells(sh1.Rows.Count, "A").End(xlUp).Row
   
    ary_d = sh1.Range(sh1.Cells(1, 1), sh1.Cells(R1, 18)) 
Set dic_d = CreateObject("Scripting.Dictionary")
    For t_row_d = 1 To UBound(ary_d, 1) 
       
        If dic_d.Exists(ary_d(t_row_d, 18)) = False Then 
            dic_d.Add ary_d(t_row_d, 18), t_row_d
        End If
    Next t_row_d
    t_row_d = 0
    ReDim ary_list(0 To dic_d.Count - 1, 0 To 18) 
    'For id = 0 To dic_d.Count - 1
        't_row_d = dic_d.items()(id)
        
   Dim ary_item
    ary_item = dic_d.Items
    For id = 0 To dic_d.Count - 1
        t_row_d = ary_item(id)
         
        ary_list(id, 0) = ary_d(t_row_d, 1)
        ary_list(id, 1) = ary_d(t_row_d, 2)
        ary_list(id, 2) = ary_d(t_row_d, 3)
        ary_list(id, 3) = ary_d(t_row_d, 4)
        ary_list(id, 4) = ary_d(t_row_d, 6)
        ary_list(id, 5) = ary_d(t_row_d, 7)
        ary_list(id, 6) = ary_d(t_row_d, 8)
        ary_list(id, 7) = ary_d(t_row_d, 9)
        ary_list(id, 8) = ary_d(t_row_d, 11)
        ary_list(id, 9) = ary_d(t_row_d, 12)
        ary_list(id, 10) = ary_d(t_row_d, 18)


    Next id
    With ListBox1
        .ColumnCount = 11      
        .ColumnWidths = "60;30;40;70;40;120;120;40;70;70;30"  
        .List = ary_list     
    End With

    Set dic_d = Nothing
   
    Application.StatusBar = False 
    Application.Calculation = xlCalculationAutomatic 
    Application.DisplayAlerts = True
    Application.EnableEvents = True 
    Application.Cursor = xlDefault
    Application.ScreenUpdating = True 
```

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

##### 上記の詳細・結果
ファイルが壊れたと思い、バックアップ用のファイルで試してうまく動いていましたがやはり出るようになりました。
1から18列までで検索するフォームですが実際のシートは20列まであるシートです。
解決策があればアドバイスお願いします。

### 補足
特になし