Home of site


Macroの杜
(VBA 編)

Calc No.1との対比用


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

Cell操作


[ General ]


[ Insert・Delete.Copy ]


[ Property(Cellの書式設定) ]


{{ Format }}


{{ Font }}




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

Cell操作


[ General ]

CCB-)[Calc]Cellに値(数字 & 文字列 & 式)を代入する(1)


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

CCB-)[Calc]Cellから値を取得する


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 ]

CCI-)[Calc]Cellの挿入(1)[既存データは下方向に移動]{1}


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

CCI-)[Calc]Cellの挿入(1)[既存データは下方向に移動]{2}


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

CCI-1)[Calc]Cellの挿入(2)[既存データは右方向に移動]


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

CCI-1)[Calc]Cellの挿入(3)[行全体が下方向に移動]


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

CCI-1)[Calc]Cellの挿入(4)[列全体が右方向に移動]


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

CCI-2)[Calc]Cellの削除


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

CCI-)[Calc]Cell範囲のCopy


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

CCI-)[Calc]形式を選択して貼り付け


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の書式設定) ]

CCProp-)[Calc]書式の解除


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 }}

CCF-)[Calc]Cellの表示形式取得


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 }}

CCFo-)[Calc]Cell幅に合わせて改行


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


CCFo-)[Excel]文字関連の Property 一覧


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  :

CCFo-)[Calc]文字列の右1文字を下付文字にする


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

CCFo-)[Calc]Cell背景


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プロパティを使う

inserted by FC2 system