EXCEL Top?
1.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 (3671d)
|