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

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

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

13問目 : セルのコピー

問題

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

解答

    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

別解

  ' 対象セルの絞り込み
  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問目 : 社外秘データの削除

問題

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

解答

  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問目：シートの並び替え

問題

シート名順でソートする。

解答

  ' ワークシート数取得
  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」にする。

解答

  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問目 : 重複キーの削除

問題

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

解答

    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

別解

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

ポイント／改善点

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

18問目 : 名前定義の削除

19問目 : 図形のコピー

問題

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

解答

  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

別解

  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」にコピーする。

解答

  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