【VBA】【book】「Excel VBA をあなたの即戦力にする」の勉強記録

日経ソフトウェア2018年9月号の第2付録の「Excel VBA をあなたの即戦力にする」の勉強記録です。

日経ソフトウエア 2018年 9 月号

日経ソフトウエア 2018年 9 月号

 

はじめに

Office 2016 Excel で VBA を使うためには次の通り設定を変えておくこと。

1. 表示される[Excelのオプション]から[リボンのユーザー設定]を選択する。
2.[メインタブ]内の[開発]にチェックを付け、[OK]をクリックする

 

01 指定したセル範囲をそのまま別シートへ転記する

  • 留意点
    • 事前に Sheet2 を作成しておくこと
    • セルの幅高はコピーされない

f:id:dnkrnka:20180817160305p:plain

Sub list01()
  Worksheets("Sheet1").Range("A1:D6").Copy Destination:=Worksheets("Sheet2").Range("A1")
End Sub

 
もしも見やすくするために改行をすると次のようにアンダスコアをエスケープシーケンスとして使うことになる。

Sub list01()
  Worksheets("Sheet1").Range("A1:D6").Copy _
  Destination:=Worksheets("Sheet2").Range("A1")
End Sub


 

02 指定したセル範囲の値のみを別シートへ転記する

PasteSpecial メソッドで値のみを転記する

  • Sheet1 の A1:D6 セルの値のみを Sheet2 の A1 セルの位置へ貼り付ける
  • 留意点
    • 事前に Sheet2 を作成しておくこと
    • セルの幅高はコピーされない

f:id:dnkrnka:20180817160305p:plain

Sub list02_1()
  Worksheets("Sheet1").Range("A1:D6").Copy
  Worksheets("Sheet2").Range("A1").PasteSpecial Paste:=xlPasteValues
End Sub

 

Valueプロパティにより値のみを転記する

Sub list02_2()
  Worksheets("Sheet2").Range("A1:D6").Value = Worksheets("sheet1").Range("A1:D6").Value
End Sub

 
 

03 指定したセル範囲の数式を別シートへ転記する

  • 下図の D列のみ数式をコピーし、その他は値をコピーする

f:id:dnkrnka:20180817170052p:plain

Sub list03_1()
  Worksheets("sheet2").Range("A1:C6").Value = Worksheets("sheet1").Range("A1:C6").Value
  Worksheets("sheet2").Range("D1:D6").Formula = Worksheets("sheet1").Range("D1:D6").Formula
End Sub

 
 

04 セル範囲を自動で取得して転記する

  • CurrentRegion はデータが連続して入力されたセル範囲を取得する
    • 空白セルは範囲外となる
  • UsedRange プロパティは編集が行われたセル範囲を取得する
    • 空白セルであっても、セルの色や文字サイズなど変更を加えたセルも範囲に含まれる

f:id:dnkrnka:20180818100157p:plain
 

CurrentRegion 使用例

Sub Sample_1 ( )
  ThisComponent.Sheets("Sheet1").Range("A1").Copy Destination:=ThisComponent.Sheets("Sheet2").Range("A1")
End Sub

以下、転記後の結果である。
f:id:dnkrnka:20180818100644p:plain
 

UsedRange 使用例

Sub list04_2()
  Worksheets("Sheet1").UsedRange.Copy Destination:=Worksheets("Sheet2").Range("A1")
End Sub

以下、転記後の結果である。
f:id:dnkrnka:20180818100833p:plain
 
 

05 セル範囲を別ブックへ転記する

  • 『転記先.xlsx』ブックの Sheet1 のセル A1 に転記する
  • 留意点
    • 事前に『転記先.xlsx』ファイルを作成しておくこと

『転記先.xlsx』を開いておくパターン

下記例では、事前に 『転記先.xlsx』 を開いておく必要がある

Sub list05_1()
  ThisWorkbook.Worksheets("Sheet1").Range("A1:D6").Copy Destination:=Workbooks("転記先.xlsx").Worksheets("Sheet1").Range("A1")
End Sub

『転記先.xlsx』をマクロから開くパターン

Sub list05_2()
  Workbooks.Open Filename:=ThisWorkbook.Path & "\転記先.xlsx"
  ThisWorkbook.Worksheets("Sheet1").Range("A1:D6").Copy Destination:=Workbooks("転記先.xlsx").Worksheets("Sheet1").Range("A1")
End Sub

 
 

06 セルを順番に1つずつ、値のみ転記する

  • For ループとカウンタ変数を使ってセルを1つずつ選択して転記していく

f:id:dnkrnka:20180818102847p:plain

転記先の原点が転記元と同じ場合

Sub list06_1()
  Dim i As Long
  Dim j As Long
  
  For i = 1 To 6
    For j = 1 To 4
      Worksheets("Sheet2").Cells(i, j).Value = Worksheets("Sheet1").Cells(i, j).Value
    Next
  Next
End Sub

 

転記先の原点を指定する場合

  • 原点を指定するために、Range("B3") を追加している
Sub list06_2()
  Dim i As Long
  Dim j As Long
  
  '転記先を2行1列ずらした B3-B8 セルに変更する
  For i = 1 To 6
    For j = 1 To 4
      Worksheets("Sheet2").Range("B3").Cells(i, j).Value = Worksheets("Sheet1").Cells(i, j).Value
    Next
  Next
End Sub

 
 

07 表の見出しより下の行のみを転記する

f:id:dnkrnka:20180818103500p:plain
 

データ入力済みのセル範囲のみを転記する

  • CurrentRegion を使う
Sub list07_1()
  '見出しを除いたセル範囲を転記する
  Dim rw As Long
  
  '表の有効行数 - 1 を算出する
  rw = Range("A1").CurrentRegion.Rows.Count - 1
  
  '表 (Range("A1").CurrentRegion) の始点から下へ1行移動(Offset(1))し、
  'rw の大きさでコピーして、A8 セルに貼り付ける
  Range("A1").CurrentRegion.Offset(1).Resize(rw).Copy Destination:=Range("A8")
End Sub

 

罫線など書式のみのセル範囲も含めて転記する

UsedRange を使う
Sub list07_2()
  '見出しを除いたセル範囲を転記する (UsedRange使用版)
  Dim rw As Long
  
  '表の有効行数 - 1 を算出する
  rw = Worksheets("Sheet1").UsedRange.Rows.Count - 1
  
  '表 (Range("A1").CurrentRegion) の始点から下へ1行移動(Offset(1))し、
  'rw の大きさでコピーして、A8 セルに貼り付ける
  Worksheets("Sheet1").UsedRange.Offset(1).Resize(rw).Copy Destination:=Range("A8")
End Sub
SpecialCells を使う
Sub list07_3()
  '見出しを除いたセル範囲を転記する (SpecialCells 使用版)
  '始点を A2、終点を使用されたセル範囲の末尾、としている
  Range(Range("A2"), Range("A2").SpecialCells(xlCellTypeLastCell)).Copy Destination:=Range("A8")
End Sub

 
 

08 セルの値を名前とするシートを連続追加する

  • 「営業2課」「営業4課」「開発1課」「開発3課」「総務課」を選択しておきマクロを実行する

f:id:dnkrnka:20180818104229p:plain

Sub list08()
  Dim c As Range
  '選択中のセルを順番に辿っていく
  For Each c In Selection
    '現在のシートの後に新規シートを追加する
    Worksheets.Add After:=Worksheets(Worksheets.Count)
    Worksheets(Worksheets.Count).Name = c.Value
  Next
End Sub

結果は以下である。
f:id:dnkrnka:20180818104403p:plain
 
 

09 不連続なセル範囲を転記する

  • Ctrlキーを使って不連続なセルを選択しても、その後コピー&ペーストは仕様上できない
  • そこで、InputBox を使って転記先を入力させることでコピー&ペーストを実現する

f:id:dnkrnka:20180818104739p:plain

Sub list09_1()
  '連続していないセルを転記する
  '通常のコピー&ペーストでは Excel の仕様でエラーになってしまうので
  'InputBox を使って転記先を入力させる
  Dim c As Range
  Dim dst As String
  Dim ofsRw As Long
  Dim ofsClmn As Long
  
  '転記先のセル番地を取得する
  dst = InputBox("転記先のセル番地を入力してください")
  '選択したセルのうち、1番目のセルの位置と転記先までの距離を取得する
  ofsRw = Range(dst).Row - Selection.Cells(1).Row
  ofsClmn = Range(dst).Column - Selection.Cells(1).Column
  
  For Each c In Selection
    If c.Row + ofsRw >= 1 And c.Column + ofsClmn >= 1 Then
      c.Copy Destination:=c.Offset(ofsRw, ofsClmn)
    End If
  Next
End Sub

マクロ実行後の結果は以下である。
f:id:dnkrnka:20180818104804p:plain
 
 

10 不要な列を除いて表を転記する

  • 下図で A列と C列のみを転記する

f:id:dnkrnka:20180818105147p:plain

  • そして、転記後は下図のようにしたい

f:id:dnkrnka:20180818105258p:plain

Sub list10_1()
  'B列とD列を除いて表を転記する
  
  '一時的に、B列とD列を非表示にする
  Range("B1,D1").Columns.Hidden = True
  
  'B列とD列を非表示にした状態で表をコピー&ペーストする
  Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy Destination:=Range("A8")
  
  'コピー&ペーストが終了したので再表示する
  Range("B1,D1").Columns.Hidden = False
End Sub

 
 

11 指定した条件に一致する値の行のみ転記する

  • 下図中の B列にて 2000円以上であれば、その行を転記する

f:id:dnkrnka:20180818105554p:plain

  • 一致した行の抽出は AutoFilter で行う
Sub list11_1()
  '条件に一致したセルのみを転記する
  With Range("A1")
    ' Range.AutoFilter(Field, Criterial) という式であるが、ここでは引数を指定して記載する
    ' B列の値が >= 2000 であれば、A8 セル以降にペーストする
    .AutoFilter Field:=2, Criterial:=">=2000"
    ' CurrentRegion を使うことで、AutoFilter で絞り込んだ状態で Copy することができる
    .CurrentRegion.Copy Destination:=Range("A8")
    .AutoFilter
  End With
End Sub

 
 

12 指定した条件に一致する値の行のみ転記する (AutoFilter不使用パターン)

  • 文字が太字かどうかで判定する場合は、AutoFilter は使えない
Sub list12_1()
  'ボールド文字の行のみを、Sheet2 の 2行目以降に転記する
  'AutoFilter ではボールド文字かどうかの判定はできないので、判定式を自作する必要がある
  Dim i     As Long
  Dim j     As Long
  Dim rw    As Long
  Dim wsOrg As Worksheet
  Dim wsDst As Worksheet
  
  Set wsOrg = Worksheets("Sheet1")
  Set wsDst = Worksheets("Sheet2")
  rw = 2
  
  For i = 2 To 5
    ' Cells(列, 行) を辿っていく
    If wsOrg.Cells(i, 1).Font.Bold = True Then
      For j = 1 To 4
        wsDst.Cells(rw, j).Value = wsOrg.Cells(i, j).Value
      Next
      rw = rw + 1
    End If
  Next
      
End Sub

 
 

13 行と列を入れ替えて転記する

・マクロ実行前
  f:id:dnkrnka:20180818110144p:plain
・マクロ実行後
  f:id:dnkrnka:20180818110229p:plain

Sub list13_1()
  '行と列を入れ替えて転記する
  Range("A1").CurrentRegion.Copy
  Range("A8").PasteSpecial Transpose:=True
End Sub

 
 

14 結合してあるセルを転記する

・マクロ実行前
  f:id:dnkrnka:20180818110550p:plain
・マクロ実行後
  f:id:dnkrnka:20180818110627p:plain

Sub list14()
  '結合したセルを転記する。結合したセルは始点(左上)と終点(右下)を指定すること。
  'なお、結合せずに転記する場合は、A1 セルのみを指定する
  'Range("A1").Copy Destination:=Range("A4")
  
  Range("A1:B2").Copy Destination:=Range("A4")
      
End Sub

 
 

15 複数の表を末尾に追加するかたちでマージする

  • 渋谷店、新宿店、池袋店 という3つのシートに、それぞれ表があるものとする
  • マクロ実行前

  渋谷店
  f:id:dnkrnka:20180818110847p:plain
  新宿店
  f:id:dnkrnka:20180818110927p:plain
  池袋店
  f:id:dnkrnka:20180818111000p:plain

  • マクロ実行後

  f:id:dnkrnka:20180818111041p:plain

Sub list15_1()
  '各シートの表にある商品情報を sheet1 にまとめる。
  'なお、各シートの見出し部分は転記しない。
  Dim ws As Worksheet
  Dim i  As Long
  Dim rw As Long
  Dim dst As Range
  
  For i = 2 To Worksheets.Count
    Set ws = Worksheets(i) ' Worksheet(2) は「渋谷店」を指す
    rw = ws.Range("A1").CurrentRegion.Rows.Count - 1
    'ws.Range("A1").CurrentRegion で見出しを含めた表のサイズを取得し
    'Offset(1) で表の原点を1行下にずらす。そして Resize をすると下に超過した
    '空白部分の行を削除したサイズにする。(つまり、縦方向に1行短くした表ができあがる)
    ws.Range("A1").CurrentRegion.Offset(1).Resize(rw).Copy
    
    Set dst = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    dst.PasteSpecial Paste:=xlPasteValues
  Next
End Sub

 
 

16 複数の表を先頭に挿入するかたちでマージする

  • 渋谷店、新宿店、池袋店 という3つのシートに、それぞれ表があるものとする
  • マクロ実行前

  渋谷店
  f:id:dnkrnka:20180818110847p:plain
  新宿店
  f:id:dnkrnka:20180818110927p:plain
  池袋店
  f:id:dnkrnka:20180818111000p:plain

  • マクロ実行後

  f:id:dnkrnka:20180818111251p:plain

Sub list16_1()
  '各シートの表にある商品情報を sheet1 に転記してまとめる。
  '転記時は表の先頭(ただし見出しは除く)に挿入するように追加する。
  'なお、各シートの見出し部分は転記しない。
  Dim wsOrg As Worksheet
  Dim wsDst As Worksheet
  Dim i  As Long
  Dim rw As Long
  Dim dst As Range
  
  Set wsDst = Worksheets(1)
  
  For i = 2 To Worksheets.Count
    Set wsOrg = Worksheets(i) ' Worksheet(2) は「渋谷店」を指す
    rw = wsOrg.Range("A1").CurrentRegion.Rows.Count - 1
    ' Rangeオブジェクト.Insert(Shift, CopyOrigin) より、
    ' Shift ... 既存セルの移動方向、CopyOrigin ... 書式を適用する隣接セル
    ' xlFormatFromRightOrBelow ... 右または下
    wsDst.Range("A2:A" & (rw + 1)).EntireRow.Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow
    
    wsOrg.Range("A1").CurrentRegion.Offset(1).Resize(rw).Copy
    wsDst.Range("A2").PasteSpecial Paste:=xlPasteValues

  Next
End Sub

 
 

17 転記と同時にバックアップを取る

  • バックアップする際のファイル名は、ファイル名の先頭に "バックアップ" を付与したものとする
  • 従ってファイル名には一意性は無いので上書きが発生するので注意すること
Sub list17()
  '転記した直後に、"バックアップ" という文字をファイル名に付与してデータをコピーする
  Range("A1").CurrentRegion.Copy Destination:=Range("A8")
  ThisWorkbook.SaveCopyAs Filename:=ThisWorkbook.Path & "\バックアップ" & ThisWorkbook.Name
End Sub