エクセルVBA備忘録。

シートの操作

データの範囲を取得　最終行と列を見つける

Sub GetDataRange()
Dim ws As Worksheet
Dim lastRow As Long
Dim lastCol As Long
Dim dataRange As Range

' シートを指定（現在アクティブなシートを対象に）
Set ws = ActiveSheet

' 最終行の取得（A列で空白じゃない最終行を探す）
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

' 最終列の取得（2行目の最終列を探す）
lastCol = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column

' データ範囲を取得
Set dataRange = ws.Range(ws.Cells(2, 1), ws.Cells(lastRow, lastCol))

' 範囲を表示
MsgBox "データ範囲は " & dataRange.Address & " です。"

End Sub

シートの削除

シート１が存在するときは削除、ないときは何もしない

Sub DeleteSheetIfExists()
Dim ws As Worksheet
Dim sheetName As String
sheetName = "シート1"

On Error Resume Next
Set ws = ThisWorkbook.Sheets(sheetName)
On Error GoTo 0

If Not ws Is Nothing Then
    Application.DisplayAlerts = False
    ws.Delete
    Application.DisplayAlerts = True
End If

End Sub

「シート1」と「シート2」の2つのシートを削除する。ない時は何もしない

Sub DeleteSheetsIfExists()
Dim ws As Worksheet
Dim sheetNames As Variant
Dim i As Integer

sheetNames = Array("シート1", "シート2")

Application.DisplayAlerts = False　　'画面を固定するコード。

For i = LBound(sheetNames) To UBound(sheetNames)
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(sheetNames(i))
    On Error GoTo 0

    If Not ws Is Nothing Then
        ws.Delete
    End If
Next i

Application.DisplayAlerts = True

End Sub

シート名の変更

Sub RenameSheet()
Dim ws As Worksheet
Dim oldName As String
Dim newName As String

oldName = "シート1" ' 変更前のシート名
newName = "新しいシート名" ' 変更後のシート名

On Error Resume Next
Set ws = ThisWorkbook.Sheets(oldName)
On Error GoTo 0

If Not ws Is Nothing Then
    ws.Name = newName
End If

End Sub

複数のシートの名前を変更したい　１

Sub RenameMultipleSheets()
Dim ws As Worksheet
Dim oldNames As Variant
Dim newNames As Variant
Dim i As Integer

oldNames = Array("シート1", "シート2")
newNames = Array("新しいシート名1", "新しいシート名2")

For i = LBound(oldNames) To UBound(oldNames)
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(oldNames(i))
    On Error GoTo 0

    If Not ws Is Nothing Then
        ws.Name = newNames(i)
    End If
Next i

End Sub

複数のシートの名前を変更したい　２

Sub RenameMultipleSheets()
Dim ws As Worksheet
Dim oldNames As Variant
Dim newNames As Variant
Dim i As Integer

' 変更前のシート名と変更後のシート名のリストを作成
oldNames = Array("シート1", "シート2", "シート3")
newNames = Array("新しいシート名1", "新しいシート名2", "新しいシート名3")

' 配列の要素数が一致するか確認
If UBound(oldNames) <> UBound(newNames) Then
    MsgBox "古い名前と新しい名前のリストの数が一致しません。", vbExclamation
    Exit Sub
End If

Application.DisplayAlerts = False

For i = LBound(oldNames) To UBound(oldNames)
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(oldNames(i))
    On Error GoTo 0

    If Not ws Is Nothing Then
        ws.Name = newNames(i)
    End If
Next i

Application.DisplayAlerts = True

End Sub

シートのコピー

シート１をコピーしてシート名をシート２にしたい

Sub CopyAndRenameSheet()
Dim ws As Worksheet
' Sheet1をコピー
Set ws = ThisWorkbook.Sheets("Sheet1")
ws.Copy Before:=ws　　　　’wsの前に置く。後ろに置く場合はafter
' コピーしたシートをSheet2にリネーム
ws.Previous.Name = "Sheet2" ’wsの前のシートの名前を変更。後ろを変更する場合はnext
End Sub

シートの操作　その他

画面を固定したい。プログラム実行中にシートが変わらないように。

' 画面の更新を停止
Application.ScreenUpdating = False

' シートを「判定シート」に固定
ThisWorkbook.Sheets("判定シート").Activate
　・
　・
　・
' 画面の更新を再開
Application.ScreenUpdating = True

列の操作

列の並び替え

並び替えたい順に別の列にコピーして、最初の列を削除

' 残したい列名の設定
keepColumns = Array("シート１, "シート2", "シート3, "シート4", "シート5", _
"シート6", "シート7", "シート8", "シート9", "シート10")

' 指定された列をL列以降にコピー
For j = LBound(keepColumns) To UBound(keepColumns)
 colIndex = Application.Match(keepColumns(j), wsSource.Rows(1), 0)
 If Not IsError(colIndex) Then
 wsSource.Columns(colIndex).Copy Destination:=wsSource.Columns(12 + j)
 End If
Next j

' A～K列を削除
wsSource.Range("A:K").Delete

列の削除

目的の列以外を削除

aaaとbbb以外の列を削除

Sub DeleteColumnsExceptAAAAndBBB()
Dim ws As Worksheet
Dim lastColumn As Long
Dim i As Long

' シートを指定します
Set ws = ThisWorkbook.Sheets("Sheet1")

' 最終列を取得します
lastColumn = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

' 右から左に向かってループを行い、"aaa" か "bbb" でない列を削除します
For i = lastColumn To 1 Step -1
    With ws.Cells(1, i)
        If .Value <> "aaa" And .Value <> "bbb" Then
            .EntireColumn.Delete
        End If
    End With
Next i

End Sub

セル値の操作

文字列を数値に変換

' 列「番号」のデータを数値に変換
Set rng = targetWs.Range("A2:A" & lastRow)
For Each cell In rng
    If IsNumeric(cell.Value) Then
        cell.Value = Val(cell.Value)
    End If
Next cell

複数のセルで数式を数値に変換する場合

Sub ConvertRangeToValues()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("シート") ' シート名を適宜変更してください

With ws.Range("A1:B10") ' A1からB10の範囲を指定
    .Value = .Value ' 範囲内の全てのセルの数式を数値に変換
End With

End Sub

セルに数式を入力して最終行までコピー

セルに数式を入力して最終行までコピーする。“0”などは””０””となることに注意！

    ' J3に数式を入力して最終行までコピー
    wsTarget.Cells(3, "J").Formula = "=IF(MID(C3,8,1)=""0"","""","""")"
    wsTarget.Range("J3:J" & lastRow).FillDown

値の操作　その他

前の月の年月を自動入力

Sub InsertPreviousMonth()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("シート") ' シート名を適宜変更してください
ws.Range("A1").Value = Format(DateSerial(Year(Date), Month(Date) - 1, 1), "yyyy/mm")
End Sub