エクセル100本ノック 11 ~ 20

# 11問目 : 実務利用度合 - 低 スキップ
# 12問目 : 実務利用度合 - 低 スキップ

# 13問目 : セルのコピー

## 問題
> Selectionは必ずしもセルとは限らず図形等の場合もあるのでTypeNameでセル選択か確認しています。
また、計算式の場合は一部のFont変更はできないのでHasFormulaで外しています。
範囲が大きいと処理時間がかかるので1列全体を上限にしました。
文字列内の一部のFont設定はCharactersで設定します。

## 解答
```vb
    Dim findResult As Range
    Dim findResultFirst As Range
    
    ' 検索処理
    Set findResult = s.Cells.Find(What:="注意")
    Set findResultFirst = findResult
    
    ' 0件の場合、中断
    If findResult Is Nothing Then
      MsgBox ("検索結果0件")
      Exit Sub
    End If
    
    ' 検索結果が一巡するまで続行
    Do
      Set findResult = Cells.FindNext(findResult)
      
      Dim strPos As Long
      strPos = 1
      strPos = InStr(strPos, findResult.Value, "注意")
      ' 1セル中の複数の検索ワード分だけ
      Do While strPos <> 0
        ' 指定した位置の文字列を赤色にする。
        findResult.Characters(Start:=strPos, Length:=2).Font.Color = RGB(255, 0, 0)
        strPos = strPos + 2
        strPos = InStr(strPos, findResult.Value, "注意")
      Loop
      
    Loop While findResult.Address <> findResultFirst.Address
```

## 別解
```vb
  ' 対象セルの絞り込み
  Set targets = Selection.SpecialCells(xlCellTypeConstants, xlTextValues)

  ' 1セルにおける文字列の検索
　With reg
　　.Pattern = argStr
　　.Global = True
　  Set mc = .Execute(rng.Value)
　End With
```

## ポイント
　・選択されている範囲で(Selection)を読み落としていた...
　・別解ではSpecialCellsを用いることで値が入っているセルのみを抽出して、処理効率を高めている。
　・RegExpを用いることで、検索結果がリスト(mc)で返却できるため、複数InStrを実行する必要がなく見栄えが良い。

# 14問目 : 社外秘データの削除

## 問題
> シート名に「社外秘」の文字が含まれる場合、削除。
他のシートは計算式を消して値だけにしてください。


## 解答
```vb
  Dim sheet As Worksheet
  For Each sheet In ThisWorkbook.Worksheets
    ' 社外秘を含むシートを削除する。
    If InStr(sheet.Name, "社外秘") <> 0 Then
      Application.DisplayAlerts = False
      sheet.Delete
      Application.DisplayAlerts = True
    ' 数式を値に置換する。
    Else
      Dim formulaRange As Range
      Set formulaRange = sheet.Range("A1").CurrentRegion.SpecialCells(xlCellTypeFormulas)
      formulaRange.Value = formulaRange.Value
      
    End If
  Next
```

## 別解
　なし
## ポイント
　・全てのシートが社外秘だったら？など事細かに想定されているが、
　　これら全てに対策を講じるのは不可能である。
　　ということで、とりあえず、最低限の対策のみ実施。

# 15問目：シートの並び替え

## 問題
> シート名順でソートする。

## 解答
```vb
  ' ワークシート数取得
  Dim sheetCount As Long
  sheetCount = ThisWorkbook.Worksheets.Count
  
  ' 全てのワークシート名を取得
  Dim sheetList() As String
  ReDim sheetList(sheetCount)

  ' ソート用のワークシートを追加
  Dim tempSheet As Worksheet
  Worksheets.Add(After:=Worksheets(sheetCount)).Name = "temp"
  Set tempSheet = ThisWorkbook.Worksheets("temp")
  
  Dim s As Worksheet
  Dim i As Long
  i = 1
  For i = 1 To sheetCount
    tempSheet.Range("A" & i).NumberFormatLocal = "@"
    tempSheet.Range("A" & i).Value = ThisWorkbook.Worksheets(i).Name
  Next
  
  ' ソート処理
  Dim endRow As Long
  tempSheet.Range("A1").CurrentRegion.Sort _
    Key1:=Range("A1"), Order1:=xlDescending, _
    Header:=xlNo
  
  ' 若い順から末尾に挿入
  For i = 1 To sheetCount
    Call ThisWorkbook.Worksheets(tempSheet.Range("A" & i).Value) _
    .Move(Before:=ThisWorkbook.Worksheets(1))
  Next
  
  ' ソート良い宇のワークシートを削除
  Application.DisplayAlerts = False
  tempSheet.Delete
  Application.DisplayAlerts = True
```

## 別解
　・あらかじめ、前後のシート名が分っているため、
　「2014年05日」は「2014年04日」としているが汎用性に欠ける。
　　（ソースコード自体は短いが）

　・バブルソートを用いた方法
　　⇒　測定していないが、Range.Sortに頼ったほうが早いはず。

## ポイント
　・VBAにはソート機能がないので、一度シートにソート用のデータを転記する。
　・転記が終わったらソートを削除する。
　・転記する際に、フォーマットが変わらないようVBA側で「文字列」を指定している。


# 16問目 : 不要な改行を削除

## 問題
> 2つ以上の「\n\n」を1つの「\n」にする。


## 解答

```vb
  With ThisWorkbook.Worksheets(1)
    
    ' 値のある部分のみ抜粋
    Set target = .Range("A1").CurrentRegion.SpecialCells(xlCellTypeConstants)
    
    Dim r As Range
    Dim reg As New RegExp
    ' 対象セル数分
    For Each r In target
      
      reg.Global = True
      ' \r\n -> \nに統一
      reg.Pattern = "\r\n"
      r.Value = reg.Replace(r.Value, vbLf)
      ' 連続する\nを削除
      reg.Pattern = "\n{2,}"
      r.Value = reg.Replace(r.Value, vbLf)
    Next
    Set reg = Nothing
  End With
```

## 別解
　・Instrの使用もあり。

## ポイント
　・10000セル/秒なので、高速化する場合は、
    Regexpを用いない泥臭い書き方をしたほうが良いかもしれない。

# 17問目 : 重複キーの削除

## 問題
> 重複を削除してユニーク化（一意化）する問題です。
社員データから、部・課マスタを作成します。


## 解答
```vb
    Set sheetEmployee = ThisWorkbook.Worksheets("社員")
    Set sheetDepartment = ThisWorkbook.Worksheets("部・課マスタ")
    
    Dim lastLow As Long
    lastLow = sheetEmployee.Cells(Rows.Count, 1).End(xlUp).Row
    
    ' 部・課情報を別シートに転記
    sheetEmployee.range("C2").Resize(lastLow - 1, 4).Copy _
      Destination:=sheetDepartment.range("A2")
 
    ' 重複削除
    sheetDepartment.range("A2").Resize(lastLow - 1, 4).RemoveDuplicates _
      Columns:=Array(1, 2), _
      Header:=xlNo
      
    ' コード順に整列する。
    With sheetDepartment
      .range("A2").Resize(lastLow - 1, 4).Sort _
         Key1:=.range("A2"), order1:=xlAscending, _
         Key2:=.range("B2"), order2:=xlAscending, _
         Header:=xlNo
    End With
```

## 別解
```vb
  ' 初期化しておかないと、正常に転記がされない。
  sheetDepartment.Cells.Clear
  sheetEmployee.Columns("C:F").AdvancedFilter _
    Action:=xlFilterCopy, _
    CopyToRange:=sheetDepartment.range("A1"), _
    Unique:=True
```

## ポイント／改善点
　・やり方はいろいろある。
　・Headerでスキップできる場合、わざわざヘッダーを含めないようにする手間が不要。
　・速度を重視する場合は、
　　　１．Dictionary
　　　２．ソートしてから前後を見て重複有無チェック

# 18問目 : 名前定義の削除
# 19問目 : 図形のコピー

## 問題
> すべての図形を複製し、元の図形の隣に配置する。


## 解答
```vb
  With ThisWorkbook.Worksheets(1)
    ' 全ての図形に対して
    For Each s In .Shapes
      ' 図形を選択、張り付けする。
      s.Select
      s.Copy
      .Paste
      ' 座標の設定
      Selection.ShapeRange.Top = s.Top
      Selection.ShapeRange.Left = s.Left + s.Height
    Next
  End With
```

## 別解
```vb
  If sp.Type <> msoFormControl And sp.Type <> msoOLEControlObject Then
    With sp.Duplicate
　　  .Name = sp.Name & "【VBA100_19】"
　　　.Top = sp.Top
　　　.Left = sp.Left + sp.Width
　　End With
　End If
```

## ポイント
・フォームに使用する部品(msoFormControl , msoOLEControlObject)など
　機能を持つ図形については複製していない。

・Duplicateを使用すると、コピーペーストの手間が少し省けて可読性が上がる。
・複製した図形かどうかを名前で判別できるようにしている。


# 20問目 : バックアップファイルの作成

## 問題
> 自身のファイルをバックアップフォルダ「BACKUP」にコピーする。


## 解答
```vb
  Dim backupDirectory As String
  Const BACKUP_FOLDER_NAME As String = "BACKUP"
  
  
  Dim fso As New FileSystemObject
  
  ' バックアップディレクトリの作成
  backupDirectory = ThisWorkbook.Path & "\\" & BACKUP_FOLDER_NAME
  If Not fso.FolderExists(backupDirectory) Then
    fso.CreateFolder backupDirectory
  End If
  
  ' タイムスタンプ付きファイル名の生成
  Dim newFileName As String
  newFileName = fso.GetBaseName(ThisWorkbook.FullName) & _
                "_" & Format(Now, "yyyymmddhhmmss") & _
                "." & _
                fso.GetExtensionName(ThisWorkbook.FullName)
  
  ' バックアップを移動
  fso.CopyFile ThisWorkbook.FullName, _
    backupDirectory & "\\" & newFileName
   
  Set fso = Nothing
```