EXCEL/FaceID2 - a羅針盤

EXCEL Top?

１．FaceId一覧の作成(2010) †

Excel2010で色々試してみましたが、一旦テンポラリーのボタンにFaceIDをセットしてその画像イメージをワークシートに張り付けるのがシンプルのようです。以下のサンプルはExcel2010で使用しましたが、その他のバージョンでも背景色のところを修正すれば動くと思います。

Option Explicit

Sub main()

    Sheet_Format
    FaceID_Draw
    
End Sub

Sub Sheet_Format()
    Dim sht     As Worksheet
    Dim block   As Integer
    Dim i       As Integer
    Dim j       As Integer
    Dim rowNo   As Integer
    
    Set sht = ActiveSheet
    
    sht.Columns("C:AA").Select
    Selection.ColumnWidth = 2.25
    sht.Rows("3:946").Select
    Selection.RowHeight = 17
    
    For block = 1 To 45
        rowNo = 21 * block - 18
        sht.Range(sht.Cells(rowNo, 3), sht.Cells(rowNo + 19, 27)).Select
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = -4.99893185216834E-02
            .PatternTintAndShade = 0
        End With
        
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With

    Next block
    
    Set sht = Nothing

End Sub

Sub FaceID_Draw()
    Dim sht         As Worksheet
    Dim block       As Integer
    Dim i           As Integer
    Dim j           As Integer
    Dim rowNo       As Integer
    Dim clmNo       As Integer
    Dim FaceID      As Long
    Dim shpRange    As ShapeRange
    
    Const TempBar   As String = "TempBar"
    Dim TempCmdBar  As CommandBar
    Dim TempBtn     As CommandBarButton
    
    On Error Resume Next
    CommandBars(TempBar).Delete
    On Error GoTo 0
    Set TempCmdBar = Application.CommandBars.Add(Name:=TempBar, Temporary:=True)

    Set TempBtn = TempCmdBar.Controls.Add(Type:=msoControlButton)
    
    Set sht = ActiveSheet
    sht.Application.ScreenUpdating = False   '更新を表示のままだと、FaceIDの画像が増えるにつれ画像をPasteした時の処理が非常に長くなります。
    
    FaceID = 1
    For block = 1 To 45
        Application.StatusBar = block
        For rowNo = 1 To 20
            sht.Cells(rowNo + 21 * block - 19, 2) = FaceID
            For clmNo = 1 To 25
                With TempBtn
                    .FaceID = FaceID
                    .CopyFace
                End With
                
                sht.Cells(rowNo + 21 * block - 19, clmNo + 2).Select
                sht.Paste
                
                FaceID = FaceID + 1
            Next clmNo
        Next rowNo
    Next block
        
    sht.Shapes.SelectAll
    Set shpRange = Selection.ShapeRange
    
    With shpRange      'FaceIDの画像をセルの中央に移動します。
        .IncrementTop 2
        .IncrementLeft 3
    End With
    
    Application.StatusBar = False
    sht.Application.ScreenUpdating = True
    Set sht = Nothing

End Sub

Sub Face_Picture_Delete()
    Dim sht     As Worksheet
    Dim shp     As Shape

    Set sht = ActiveSheet
    For Each shp In sht.Shapes
        If shp.Type = msoPicture Then
            shp.Delete
        End If
    Next shp
    
    Set sht = Nothing

End Sub

Last-modified: 2014-03-11 (火) 01:58:42 (4133d)