Home of site

Macroの杜
(VBA 編)

Calc No.1との対比用

**********************【 Index 】**********************

Cell操作

[ General ]

CCB-)[Excel]Cellに値(数字 ＆ 文字列 ＆ 式)を代入する(1) ⇔ Enter the value to the Cell(1)[ ]
CCB-)[Excel]Cellから値を取得する ⇔ Get the value from Cell[ ]

[ Insert･Delete.Copy ]

CCI-)[Excel]Cellの挿入(1)[既存データは下方向に移動]{1} ⇔ Insert the Cell(1)[Shift down]{1}[ ]
CCI-)[Excel]Cellの挿入(1)[既存データは下方向に移動]{2} ⇔ Insert the Cell(1)[Shift down]{2}[ ]
CCI-)[Excel]Cellの挿入(2)[既存データは右方向に移動] ⇔ Insert the Cell(2)[Shift Right]{1}[ ]
CCI-)[Excel]Cellの挿入(3)[行全体が下方向に移動] ⇔ Insert the Cell(3)[Shift row down][ ]
CCI-)[Excel]Cellの挿入(4)[列全体が右方向に移動] ⇔ Insert the Cell(4)[Shift column right][ ]
CCI-)[Excel]Cellの削除 ⇔ Delete the Cell[ ]
CCI-)[Excel]Cell範囲のCopy ⇔ Copy the cell range[ ]
CCI-)[Excel]形式を選択して貼り付け ⇔ Special paste[ ]

[ Property(Cellの書式設定) ]

CCProp-)[Excel]書式の解除 ⇔ [ ]

{{ Format }}

CCF-)[Excel]Cellの表示形式取得 ⇔ Get the cell format

{{ Font }}

CCFo-)[Excel]Cell幅に合わせて改行 ⇔ Wrap in the cell width(1)[ ]
CCFo-)[Excel]文字関連の Property 一覧 ⇔ Properties of the string[ ]
CCFo-)[Excel]文字列の右1文字を下付文字にする ⇔ To subfix the right letter[ ]

**********************【 Macro Code 】**********************

Cell操作

[ General ]

Sub EnterCell()
    Workbooks(1).Worksheets(1).Cells(1, 1) = 1
    Workbooks(1).Worksheets(1).Cells(2, 1) = "test"
    Workbooks(1).Worksheets(1).Cells(3, 1) = "=A1*10"
    MsgBox "Success", 0, "Win10(32bit)"
End Sub

Const m = 4
Sub GetCellVal()
    ReDim mVal(m) As Variant
    Dim mCellType As String
    Dim mTemp As Variant
    Dim mDisp As String
        mDisp = ""
        For i = 1 To m
            mCellType = TypeName(Workbooks(1).Worksheets(1).Cells(i, 1).Value)
            Select Case mCellType
                Case "Empty"
                    mVal(i) = "空白です。"
                Case "String"
                    mVal(i) = CStr(Workbooks(1).Worksheets(1).Cells(i, 1).Text)
                Case Else
                    If IsFormula(Workbooks(1).Worksheets(1).Cells(i, 1)) = False Then
                        mVal(i) = CStr(Workbooks(1).Worksheets(1).Cells(i, 1).Value)
                    Else
                        mVal(i) = CStr(Workbooks(1).Worksheets(1).Cells(i, 1).Formula)
                    End If
            End Select
            mDisp = mDisp & "A" & i & " Cellの値 : " & mVal(i) & Chr(10)
        Next i
    MsgBox mDisp, 0, "Success (Win10)"
End Sub
'
Function IsFormula(fCell As Range) As Boolean
    IsFormula = fCell.HasFormula
End Function

[ Insert･Delete.Copy ]

Sub InsertCellDown()
    Dim mDisp As String
        Workbooks(1).Worksheets(1).Range(Cells(3, 3), Cells(5, 5)).Select
        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        mDisp = "Incert Cell"
    	mDisp = "Success" & Chr(10) & "(Windows10)"
    	MsgBox mDisp, 0, "Success (Win10)"
End Sub

Sub InsertCellDown()
    Dim mDisp As String
        Application.ActiveCell.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        mDisp = "Incert Cell"
    MsgBox mDisp, 0, "Success (Win10)"
End Sub

Sub InsertCellDown()
    Dim mDisp As String
        Workbooks(1).Worksheets(1).Range(Cells(3, 3), Cells(5, 5)).Select
        Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        mDisp = "Success" & Chr(10) & "(Windows10)"
		MsgBox mDisp, 0, "MS-Excel 2007"
End Sub

Sub InsertCellRow()
    Dim mDisp As String
    Dim iStart As Integer
    Dim iRows As Integer
    Dim iSheetIndex As Integer
        iSheetIndex = 1
        iStart = 1
        iRows = 3
        Workbooks(1).Worksheets(iSheetIndex).Range(Cells(iStart, 1), Cells(iStart + iRows, 3)).Select
        Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
        mDisp = "Success" & Chr(10) & "(Windows10)"
        MsgBox mDisp, 0, "MS-Excel 2007"
End Sub

Sub InsertCellCol()
    Dim mDisp As String
    Dim iStart As Integer
    Dim iRows As Integer
    Dim iSheetIndex As Integer
        iSheetIndex = 1
        iStart = 1
        iRows = 3
        Workbooks(1).Worksheets(iSheetIndex).Range(Cells(iStart, 1), Cells(iStart + iRows, 3)).Select
        Selection.EntireColumn.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
        mDisp = "Success" & Chr(10) & "(Windows10)"
        MsgBox mDisp, 0, "MS-Excel 2007"
End Sub

Sub DelteCell()
    Dim mDisp As String
        Workbooks(1).Worksheets(1).Range(Cells(3, 3), Cells(5, 5)).Select
        Selection.Delete Shift:=xlUp
        mDisp = "Delete Cell"
        mDisp = "Success" & Chr(10) & "(Windows10)"
        MsgBox mDisp, 0, "Success (Win10)"
End Sub
'
' Sift Up			→　Selection.Delete Shift:=xlUp
' Sift Left			→　Selection.Delete Shift:=xlToLeft
' Sift Row Up		→　Selection.EntireRow.Delete
' Sift Column Left	→　Selection.EntireColumn.Delete

Sub Cell_Copy()
    Dim mDisp As String
        Workbooks(1).Worksheets(1).Range("A1:B5").Select
        Selection.Copy
        Workbooks(1).Worksheets(1).Range("C1").Select
        ActiveSheet.Paste
        mDisp = "Copy and Paste of Cell range"
        mDisp = "Success" & Chr(10) & "(Windows10)"
        MsgBox mDisp, 0, "Success (Win10)"
End Sub
'
' [ Note ]
' NG : Selection.Paste

Sub Special_Copy()
    Dim mDisp As String
        Workbooks(1).Worksheets(1).Range("A1:B5").Select
        Selection.Copy
        Workbooks(1).Worksheets(1).Range("C1").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        mDisp = "Copy and Special Paste of Cell range"
        mDisp = "Success" & Chr(10) & "(Windows10)"
        MsgBox mDisp, 0, "Success (Win10)"
End Sub
'
' すべて    → Paste:=xlPasteAll
' 数式      → Paste:=xlPasteFormulas
' 値        → Paste:=xlPasteValues
' 書式      → Paste:=xlPasteFormats
' コメント  → Paste:=xlPasteComments
' 入力規則  → Paste:=xlPasteValidation
' コピー元のテーマを使用したすべて貼り付け → Paste:=xlPasteAllUsingSourceTheme
' 罫線を除くすべて  → Paste:=xlPasteAllExceptBorders
' 列幅      → Paste:=xlPasteColumnWidths
' 数式と数値の書式  → Paste:=xlPasteFormulasAndNumberFormats
' 値と数値の書式    → Paste:=xlPasteValuesAndNumberFormats

[ Property(Cellの書式設定) ]

Sub CellClearFormat()
    Dim mDisp As String
        Workbooks(1).ActiveSheet.Range("A1").Select
        Selection.ClearFormats
        mDisp = "Clear Format"
        mDisp = "Success" & Chr(10) & "(Windows10)"
        MsgBox mDisp, 0, "Success (Win10)"
End Sub

{{ Format }}

Const m = 3
Sub CellClearFormat()
    ReDim vCellFormat(m) As String
    Dim mDisp As String
        mDisp = "[ NumberFormat ]" & Chr(10)
        For i = 1 To m
            vCellFormat(i) = Workbooks(1).ActiveSheet.Cells(i, 1).NumberFormat
            mDisp = mDisp & vCellFormat(i) & Chr(10)
        Next i
        mDisp = mDisp & Chr(10) & "[ NumberFormatLocal ]" & Chr(10)
        For i = 1 To m
            vCellFormat(i) = Workbooks(1).ActiveSheet.Cells(i, 1).NumberFormatLocal
            mDisp = mDisp & vCellFormat(i) & Chr(10)
        Next i
        MsgBox mDisp, 0, "Success (Win10)"
End Sub

{{ Font }}

Sub vWrapping()
    Workbooks(1).Worksheets(1).Cells(1, 1) = "MicroSoft Office 2007"
    Workbooks(1).Worksheets(1).Cells(1, 1).Select
    With Selection
        .WrapText = True
    End With
    MsgBox "Success", 0, "Win10(32bit)"
End Sub

Sub vCellFontProp()
    Workbooks(1).Worksheets(1).Cells(2, 1) = "水素はH2"
    Workbooks(1).Worksheets(1).Cells(2, 1).Select
    '
    ' Cell全体のFont設定
    With Selection.Font
        .Name = "Arial"
        .FontStyle = "Bold Italic"
        .Size = 40
    End With
    '
    ' 前から3文字(「水素は」)のFont設定
    With ActiveCell.Characters(Start:=1, Length:=3).Font
        .Size = 30				
        .Strikethrough = True	' 取り消し線
        .Superscript = True     ' 上付き文字
        .Subscript = False      ' 下付き文字
        .OutlineFont = False    ' アウトラインフォント
        .Shadow = True          ' 影付きFont
        .Underline = xlUnderlineStyleDoubleAccounting     '下線
        .ThemeColor = xlThemeColorLight1                  ' 配色のテーマカラー
        .TintAndShade = 0                                 ' 色を明るく、または暗く
        .ThemeFont = xlThemeFontNone                      ' テーマのFont
    End With
    MsgBox "Success", 0, "Win10(32bit)"
End Sub
'
' [ Note ]
' Underlineの種類
' xlUnderlineStyleNone      : 無し
' xlUnderlineStyleSingle    : 一重
' xlUnderlineStyleDoble     : 二重
' xlUnderlineStyleDoubleAccounting  :

Sub vCellFont()
    Dim oCahrLength As Long
        Workbooks(1).Worksheets(1).Cells(2, 1) = "水素はH2"
        Workbooks(1).Worksheets(1).Cells(2, 1).Select
        '
        ' Cell全体のFont設定
        vFontSize = 25
        With Selection.Font
            .Name = "Arial"
            .FontStyle = "Bold Italic"
            .Size = vFontSize
        End With
        '
        ' ' 右一文字を下付き
        oCahrLength = Len(oString)
        With ActiveCell.Characters(Start:=oCahrLength, Length:=oCahrLength).Font
            .Subscript = True      ' 下付き文字
        End With
    MsgBox "Success", 0, "Win10(32bit)"
End Sub

Sub BackColorOfCell()
    Dim mDisp As String
        Workbooks(1).Worksheets(1).Range("A1:A2").Select
        Selection.Interior.Color = RGB(0, 255, 0)
        MsgBox "Change Back Color!!", 0, "Win10(32bit)"
        ' A1 Cellの背景を塗りつぶしなしにする。(元に戻す)
        Workbooks(1).Worksheets(1).Range("A1").Select
        Selection.Interior.ColorIndex = xlColorIndexNone
        MsgBox "Remove Back Color!!", 0, "Win10(32bit)"
End Sub
'
' [ Note ]
' 塗りつぶしなしにするには、.Coloプロパティでなく、ColorIndexプロパティを使う