Porc negre

January172011

vvf

‘////////////////////////// ‘/ ‘/　　『ＦａｃｅＩｄ一覧の表示』 ‘/　　　このマクロは「エクセルファンクラブ』 ‘/　　　ＶＢＡラウンジで回答したものです ‘/　　　自由にコピーして各自のマクロにコピー ‘/　　　しても構いません　　（角田） ‘/ ‘/ 2001/10/9 コマンドバーの『閉じるボタン(X)』を ‘/ 無効(非表示)にするプロパティを追加 ‘/ ‘//////////////////////////

Public strRow As String

Private Const cstBarName As String = “FaceId一覧” Private int表示位置 As Integer

Public Sub FaceId表示() int表示位置 = 1 Call FaceId一覧表示 End Sub

Private Sub FaceId表示Previous() Dim MyCB As CommandBar On Error Resume Next ‘ボタンクリック時に呼ばれるからコマンドバーは必ず存在する Set MyCB = Application.CommandBars(cstBarName) int表示位置 = Val(MyCB.Controls(2).Caption) ‘[～]の前のみ Set MyCB = Nothing

If (int表示位置 > 1) Then
    int表示位置 = int表示位置 - 500
    Call FaceId一覧表示
End If

End Sub

Private Sub FaceId表示Next() Dim MyCB As CommandBar On Error Resume Next ‘ボタンクリック時に呼ばれるからコマンドバーは必ず存在する Set MyCB = Application.CommandBars(cstBarName) int表示位置 = Val(MyCB.Controls(2).Caption) ‘[～]の前のみ Set MyCB = Nothing

If (int表示位置 < 4001) Then
    int表示位置 = int表示位置 + 500
    Call FaceId一覧表示
End If

End Sub

Private Sub FaceId一覧表示() Dim i As Integer Dim j As Integer Dim MyCB As CommandBar Dim MyCBCtrl As CommandBarControl ‘——————-コマンドバー作成(Temporary)——————- On Error Resume Next Set MyCB = Application.CommandBars(cstBarName) On Error GoTo 0 If (MyCB Is Nothing) Then ‘——————- 初回表示 ——————————————- Set MyCB = Application.CommandBars.Add(cstBarName, , , True) ’ コマンドバーの「閉じるボタン(X)」を無効(非表示)にする MyCB.Protection = msoBarNoChangeVisible ‘Controls(1) Set MyCBCtrl = MyCB.Controls.Add(Type:=msoControlButton) With MyCBCtrl .FaceId = 132 ’ (←) .TooltipText = “前の500個” .OnAction = “FaceId表示Previous” End With ‘Controls(2) Set MyCBCtrl = MyCB.Controls.Add(Type:=msoControlButton) With MyCBCtrl .Style = msoButtonCaption .Caption = “1～500” End With ‘Controls(3) Set MyCBCtrl = MyCB.Controls.Add(Type:=msoControlButton) With MyCBCtrl .FaceId = 133 ’ (→) .TooltipText = “次の500個” .OnAction = “FaceId表示Next” End With ‘Controls(4) Set MyCBCtrl = MyCB.Controls.Add(Type:=msoControlButton) With MyCBCtrl .FaceId = 358 .TooltipText = “FaceId一覧の消去” .OnAction = “FaceId一覧削除” End With ‘Controls(5)～(504) For i = 1 To 500 Set MyCBCtrl = MyCB.Controls.Add(Type:=msoControlButton) With MyCBCtrl If (i = 1) Then .BeginGroup = True End If .FaceId = i .TooltipText = “(” & i & “)” End With Next i

    With MyCB
        .Width = MyCB.Controls(5).Width * 26    ' (25個分+α)
        .Top = 50
        .Left = 50
        .Visible = True
    End With

‘——————- 表示範囲の書き換え ————————————— Else With MyCB.Controls(2) ’ 表示範囲 .Caption = int表示位置 & “～” & int表示位置 + 499 End With

    For i = 1 To 500
        With MyCB.Controls(i + 4)   '(5)～(504)
            j = int表示位置 + i - 1
            .FaceId = j
            .TooltipText = "(" & j & ")"
        End With
    Next i
    MyCB.Visible = True
End If

Set MyCBCtrl = Nothing
Set MyCB = Nothing

End Sub

Private Sub FaceId一覧削除() On Error Resume Next Application.CommandBars(cstBarName).Delete End Sub

Sub 同一Sheetの複数画面表示() ’ ’ Keyboard Shortcut: ’ Dim sBookName As String Dim nLen As Integer sBookName = ActiveWindow.Caption nLen = Len(sBookName) ActiveWindow.NewWindow If Mid(sBookName, nLen - 1, 1) <> “:” Then Windows(sBookName & “:1”).Activate End If Windows.Arrange ArrangeStyle:=xlHorizontal

End Sub

Sub すべてのシートをHOME_Positionへ()

Dim ws As Variant
For Each ws In Worksheets
    If Sheets(ws.Name).Visible = True Then
            Sheets(ws.Name).Select
            Range("A1").Select
    End If
Next
Sheets(1).Select

End Sub

Sub セル移動方向切替()

If Application.MoveAfterReturn = False Then
    Application.MoveAfterReturn = True
    Application.MoveAfterReturnDirection = xlDown
    Exit Sub
End If

If Application.MoveAfterReturnDirection = xlDown Then
    Application.MoveAfterReturnDirection = xlToRight
Else
    Application.MoveAfterReturnDirection = xlDown
End If

End Sub

Sub 枠線表示切替え()

ActiveWindow.DisplayGridlines = Not (ActiveWindow.DisplayGridlines)

End Sub

Sub 行列番号表示切替()

ActiveWindow.DisplayHeadings = Not (ActiveWindow.DisplayHeadings)

End Sub

Sub 全シート表示()

Dim ws As Variant
For Each ws In Sheets
    Sheets(ws.Name).Visible = True
Next
Sheets(1).Select

End Sub

Sub シート隠蔽()

Dim ws As Variant
Dim response As Integer
Dim i As Integer
Dim cnt As Integer
cnt = 0

For Each ws In Sheets
    If Sheets(ws.Name).Visible = True Then '表示されているシートの数
        cnt = cnt + 1
    End If
Next
i = 0

For Each ws In Sheets
    If Sheets(ws.Name).Visible = True Then
        Sheets(ws.Name).Select
        i = i + 1
        response = MsgBox("シート(" & i & ") 【 " & ws.Name & " 】 を隠しますか？" & Chr$(13) & Chr$(13), _
                       vbYesNoCancel + vbQuestion + vbDefaultButton2, "確認！")
        If response = vbYes Then
            If cnt = 1 Then
                MsgBox "全てのシートを非表示にする事は出来ません！", vbExclamation
                Exit Sub
            End If
            Sheets(ws.Name).Visible = False
            cnt = cnt - 1
        Else
            If response = vbCancel Then
                Exit Sub
            End If
        End If
    End If
Next

End Sub

Sub セル縦位置中央揃え() ’ ’ With Selection .VerticalAlignment = xlCenter End With End Sub

Sub A1_R1C1()

If Application.ReferenceStyle = xlR1C1 Then
    Application.ReferenceStyle = xlA1
Else
    Application.ReferenceStyle = xlR1C1
End If

End Sub

Sub Auto_Open() ’ Menu削除 1 ‘ここで起動時に（念のためいったん削除してから）メニューを追加（作成）します Menu追加 1 ‘既にauto_open() を記述している場合は、以下の２行を追加します。 Add_RightClickMenu_2 1

'INSERTに行の挿入をセット
Application.OnKey "{INSERT}", "AS_RowsInsert"

’ ‘Ctrl+B に、値のみ貼り付けをセット ’ Application.OnKey “^b”, “AS_PasteValue”

With Application.CommandBars("reviewing")
    .Enabled = Not .Enabled
End With

‘auto_open に既に他のマクロが記述されている場合には､ ‘この１行だけを追加する ’ End Sub Sub AS_PasteValue()

'値のみ貼り付けコマンドを実行
Selection.PasteSpecial Paste:=xlValues

End Sub

Private Sub AS_RowsInsert() ‘行の挿入 Application.SendKeys “%ir”

End Sub

Sub SetDefault()

Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select
Sheets("Sheet1").Activate
Cells.Select
Selection.ColumnWidth = 1.25
Selection.RowHeight = 12.5
Sheets("Sheet3").Select
Range("A1").Select
Sheets("Sheet2").Select
Range("A1").Select
Sheets("Sheet1").Select
Range("A1").Select

End Sub

Sub Add_RightClickMenu_2(num%) ‘標準メニューの下に追加 ‘auto_openに追加するのを忘れずに！

Dim cstBar As CommandBar
Dim i As Long

For i = 23 To 28        'Excel97の場合は 21 to 26 にして下さい
                        'Excel2003の場合は 29 to 34 にして下さい
    Application.CommandBars(i).Reset
    Set cstBar = CommandBars(i)
    cstBar_sub_2 cstBar
Next

’ End Sub

Sub cstBar_sub_2(cstBar As CommandBar)

Dim i%

i = cstBar.Controls.Count + 1
With cstBar
    .Controls.Add Type:=msoControlButton
    .Controls(i).Caption = "値のみ貼り付け"
    .Controls(i).OnAction = "AS_PasteValue"
    .Controls(i).FaceId = 2062
End With

i = cstBar.Controls.Count + 1
With cstBar
    .Controls.Add Type:=msoControlButton
    .Controls(i).Caption = "セル縦位置中央揃え"
    .Controls(i).OnAction = "セル縦位置中央揃え"
    .Controls(i).FaceId = 2062
End With

i = i + 1
With cstBar
    .Controls.Add Type:=msoControlButton
    .Controls(i).Caption = "センタリング"
    .Controls(i).OnAction = "センタリング"
    .Controls(i).FaceId = 122
    .Controls(i).BeginGroup = True
End With

i = i + 1
With cstBar
    .Controls.Add Type:=msoControlButton
    .Controls(i).Caption = "現在のシート名を取得"
    .Controls(i).OnAction = "シート名取得"
    .Controls(i).FaceId = 593
    .Controls(i).BeginGroup = True
End With

i = i + 1
With cstBar
    .Controls.Add Type:=msoControlButton
    .Controls(i).Caption = "現在のシート名に設定"
    .Controls(i).OnAction = "シート名設定"
    .Controls(i).FaceId = 592
    .Controls(i).BeginGroup = True
End With

’ i = i + 1 ’ With cstBar ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “ｱｸﾃｨﾌﾞｼｰﾄの複数画面表示” ’ .Controls(i).OnAction = “同一Sheetの複数画面表示” ’ .Controls(i).FaceId = 585 ’ .Controls(i).BeginGroup = True ’ ’ End With ‘

’ ’ i = i + 1 ’ With cstBar ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “全シートをHOMEポジションに” ’ .Controls(i).OnAction = “すべてのシートをHOME_Positionへ” ’ .Controls(i).FaceId = 1826 ’ .Controls(i).BeginGroup = True ’ End With ” ’ i = i + 1 ’ With cstBar ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “入力後のセル移動方向の変更” ’ .Controls(i).OnAction = “セル移動方向切替” ’ .Controls(i).FaceId = 133 ’ End With ’ ’ i = i + 1 ’ With cstBar ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “枠線の表示切替” ’ .Controls(i).OnAction = “枠線表示切替え” ’ .Controls(i).FaceId = 217 ’ End With ” ’ i = i + 1 ’ With cstBar ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “行列番号の表示切替” ’ .Controls(i).OnAction = “行列番号表示切替” ’ .Controls(i).FaceId = 800 ’ End With ” ’ i = i + 1 ’ With cstBar ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “A1形式R1C1形式の切替” ’ .Controls(i).OnAction = “A1_R1C1” ’ .Controls(i).FaceId = 503 ’ End With ” ’ i = i + 1 ’ With cstBar ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “ｼｰﾄを確認しながら非表示にする” ’ .Controls(i).OnAction = “シート隠蔽” ’ .Controls(i).FaceId = 1641 ’ End With ‘

’ With cstBar ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “選択したセルの情報(&L)” ’ .Controls(i).OnAction = “CellsInformation” ’ .Controls(i).FaceId = 343 ’ .Controls(i).BeginGroup = True ’ End With ’ ’ i = i + 1 ’ With cstBar ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “ウィンドウの上下整列(&1)” ’ .Controls(i).OnAction = “ウィンドウの上下整列” ’ .Controls(i).FaceId = 298 ’ End With ’ ’ i = i + 1 ’ With cstBar ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “最近使用したファイルの一覧に追加(&E)” ’ .Controls(i).OnAction = “Add_RecentFiles” ’ .Controls(i).FaceId = 462 ’ End With ” ’ i = i + 1 ’ With cstBar ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “全ての隠しｼｰﾄを表示する(&Q)” ’ .Controls(i).OnAction = “全シート表示” ’ .Controls(i).FaceId = 2587 ’ .Controls(i).BeginGroup = True ’ End With ’ ’ ’ i = i + 1 ’ With cstBar ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “ｾﾙ縦位置上詰め(&4)” ’ .Controls(i).OnAction = “セル縦位置上詰め” ’ .Controls(i).FaceId = 2061 ’ End With ’ ’ i = i + 1 ’ With cstBar ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “列幅で折り返し(&5)” ’ .Controls(i).OnAction = “列幅折り返し表示” ’ .Controls(i).FaceId = 119 ’ End With ‘

End Sub

Sub Reset_RightClickMenu() ‘右クリックメニューを初期化する場合はこのマクロを実行 2003/10/26 ’ Dim i As Long

For i = 23 To 28
    Application.CommandBars(i).Reset
Next

’ End Sub

Sub auto_close()

Menu削除 1        'エクセル終了時にメニューを削除します

End Sub

Sub Menu追加(num%) ‘ダミーの引数(num%)を付けているのは、「ツール」「マクロ」から指定できないようにするため

’ Faceid （アイコン）を調べたい時は「FaceId一覧表示」を使う Dim myBar As CommandBar Dim myCtrl As CommandBarControl Dim i% ’ Application.CommandBars(“Worksheet Menu Bar”).Reset ‘20010224 Menu削除 1 ‘20021021 Set myBar = CommandBars(“Worksheet Menu Bar”) Set myCtrl = myBar.Controls.Add(Type:=msoControlPopup, Temporary:=True) With myCtrl ”最初にココで、メニューバーに追加するメニュー名を指定する。 .Move Before:=9 .Caption = “MyTools(&X)” ‘(&英数字)はアクセスキーの指定（なくてもOK） .Visible = True

’ i = i + 1 ’ ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “ｳｨﾝﾄﾞｳの上下整列(&1)” ‘メニュー名の後ろに(&英数字)と記述すると、アクセスキーの指定になる（なくてもOK） ’ .Controls(i).OnAction = “ウィンドウの上下整列” ’ .Controls(i).FaceId = 298 ’ .Controls(i).BeginGroup = True ‘これを指定すると、メニューをセパレートする横棒が入る ’ i = i + 1 .Controls.Add Type:=msoControlButton .Controls(i).Caption = “セル縦位置中央揃え” .Controls(i).OnAction = “セル縦位置中央揃え” .Controls(i).FaceId = 2062 .Controls(i).BeginGroup = True

    i = i + 1
    .Controls.Add Type:=msoControlButton
    .Controls(i).Caption = "全シートをHomePositionに"
    .Controls(i).OnAction = "すべてのシートをHOME_Positionへ"
    .Controls(i).FaceId = 1826
    .Controls(i).BeginGroup = True

    i = i + 1
    .Controls.Add Type:=msoControlButton
    .Controls(i).Caption = "シート順ソート"
    .Controls(i).OnAction = "シート並び替え"
    .Controls(i).FaceId = 654

    i = i + 1
    .Controls.Add Type:=msoControlButton
    .Controls(i).Caption = "入力後のセル移動方向の変更"
    .Controls(i).OnAction = "セル移動方向切替"
    .Controls(i).FaceId = 133

    i = i + 1
    .Controls.Add Type:=msoControlButton
    .Controls(i).Caption = "枠線の表示切替"
    .Controls(i).OnAction = "枠線表示切替え"
    .Controls(i).FaceId = 217

    i = i + 1
    .Controls.Add Type:=msoControlButton
    .Controls(i).Caption = "行列番号の表示切替"
    .Controls(i).OnAction = "行列番号表示切替"
    .Controls(i).FaceId = 800

    i = i + 1
    .Controls.Add Type:=msoControlButton
    .Controls(i).Caption = "A1形式R1C1形式の切替"
    .Controls(i).OnAction = "A1_R1C1"
    .Controls(i).FaceId = 503
    .Controls(i).BeginGroup = True

    i = i + 1
    .Controls.Add Type:=msoControlButton
    .Controls(i).Caption = "ActiveSheetの複数画面表示"
    .Controls(i).OnAction = "同一Sheetの複数画面表示"
    .Controls(i).FaceId = 585

    i = i + 1
    .Controls.Add Type:=msoControlButton
    .Controls(i).Caption = "全ての隠しシートを表示する"
    .Controls(i).OnAction = "全シート表示"
    .Controls(i).FaceId = 2587

    i = i + 1
    .Controls.Add Type:=msoControlButton
    .Controls(i).Caption = "シートを確認しながら非表示にする"
    .Controls(i).OnAction = "シート隠蔽"
    .Controls(i).FaceId = 1641

    i = i + 1
    .Controls.Add Type:=msoControlButton
    .Controls(i).Caption = "シート初期化"
    .Controls(i).OnAction = "setdefault"
    .Controls(i).FaceId = 800

End With

End Sub

Sub Menu削除(num%)

Dim myBar  As CommandBar

Set myBar = CommandBars("Worksheet Menu Bar")
On Error Resume Next
myBar.Controls("MyTools(&X)").Delete
On Error GoTo 0

End Sub Sub CAVSCOT()

Dim i As Integer Dim j As Integer Dim k As Integer i = 1 k = 0

Load UserForm1 UserForm1.Show UserForm1.SetDefaultTabOrder

If strRow = “” Or _ IsNull(strRow) = True Then Else

Cells.Select
Selection.Sort Key1:=Range(strRow & "1"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
    :=xlPinYin, DataOption1:=xlSortTextAsNumbers

Do Until IsEmpty(Range(strRow & i).Value)
    j = i + 1

    If Range(strRow & i) = Range(strRow & j) Then
            Rows(j & ":" & j).Select
            Selection.Delete Shift:=xlUp
        Else
            i = i + 1
    End If

Loop

End If

Cavscot_Exit: ’ FRM_USERをｱﾝﾛｰﾄﾞしｵﾌﾞｼﾞｪｸﾄを解放 Unload UserForm1 Set UserForm1 = Nothing End Sub

Sub 指定した列のデータでシート分け() Dim workSh As Worksheet Dim tempSh As Worksheet Dim mRng As Range Dim sRng As Range, sR As Range Dim st$ Dim i As Long, j As Integer

Application.ScreenUpdating = False
Set workSh = ActiveSheet
Load UserForm1
UserForm1.Show
UserForm1.SetDefaultTabOrder

If strRow = "" Or _
   IsNull(strRow) = True Then
Else
    Cells.Select
    Selection.Sort Key1:=Range(strRow & "1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
        :=xlPinYin, DataOption1:=xlSortTextAsNumbers

    With workSh
        'データテーブル作成
        Set mRng = .Range(strRow & "1").CurrentRegion
        .Range("IV1") = .Range(strRow & "1").Value
        .Range("IT1") = .Range(strRow & "1").Value
        mRng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("IV1"), Unique:=False
        'データ毎にシート作成、該当データ抽出
        Set sRng = .Range("IV1").CurrentRegion
        For i = 2 To sRng.Rows.Count
            .Range("IT2") = sRng(i, 1)
            Set sR = .Range("IT1").CurrentRegion

            'シートの存在チェック
            st = CStr(sR(2, 1)) '調べるシート名
            If TypeName(Application.Evaluate(st & "!A1")) = "Range" Then
                'シートがある時は中身をクリア
                Worksheets(CStr(sR(2, 1))).Activate
                Cells.Select
                Cells.Delete
            Else
              With Worksheets.Add()
                      .Name = CStr(sR(2, 1))
              End With
            End If

            Set tempSh = Worksheets(st)
            mRng.AdvancedFilter xlFilterCopy, sR, tempSh.Range("A1"), False
            tempSh.Range(strRow & "1").EntireRow.Delete xlUp
        Next
        sR.Clear
        sRng.Clear
        Set sRng = Nothing: Set mRng = Nothing
    End With
    Application.ScreenUpdating = True
End If

End Sub

Sub シート名設定()

If ActiveCell.Value = "" Or Null Then
Else
    If Len(ActiveCell.Value) >= 31 Then
        MsgBox "文字数が多すぎます！"
    Else
    If InStr(StrConv(ActiveCell.Value, 8), ":") > 0 Then
        MsgBox "記号は入力できません！"
        Exit Sub
    End If

    If InStr(StrConv(ActiveCell.Value, 8), "*") > 0 Then
        MsgBox "記号は入力できません！"
        Exit Sub
    End If

    If InStr(StrConv(ActiveCell.Value, 8), "/") > 0 Then
        MsgBox "記号は入力できません！"
        Exit Sub
    End If

    If InStr(StrConv(ActiveCell.Value, 8), "\") > 0 Then
        MsgBox "記号は入力できません！"
        Exit Sub
    End If

    If InStr(StrConv(ActiveCell.Value, 8), "?") > 0 Then
        MsgBox "記号は入力できません！"
        Exit Sub
    End If

    If InStr(StrConv(ActiveCell.Value, 8), "[") > 0 Then
        MsgBox "記号は入力できません！"
        Exit Sub
    End If

    If InStr(StrConv(ActiveCell.Value, 8), "]") > 0 Then
        MsgBox "記号は入力できません！"
        Exit Sub
    End If

    ActiveSheet.Name = ActiveCell.Value
    End If
End If

End Sub

Sub シート名取得()

ActiveCell.Value = ActiveSheet.Name

End Sub

Sub シート結合() Dim シート数 As Integer Dim i As Integer Dim 最終行 As Long

Worksheets.Add Before:=Worksheets(1)

シート数 = Worksheets.Count For i = 2 To シート数 Worksheets(i).Range(“A2”).CurrentRegion.Copy 最終行 = Worksheets(1).Cells.SpecialCells(xlCellTypeLastCell).Row Worksheets(1).Cells(最終行 + 2, 1).Select Worksheets(1).Paste Next

End Sub

Sub シート並び替え()

Dim intLoopA As Integer Dim intLoopB As Integer

For intLoopA = 1 To Sheets.Count For intLoopB = 1 To Sheets.Count - 1 If Sheets(intLoopB).Name > Sheets(intLoopB + 1).Name Then Sheets(intLoopB).Move after:=Sheets(intLoopB + 1) End If Next intLoopB Next intLoopA

End Sub

Sub 縮小して全体を表示() ’ ’ Keyboard Shortcut: Ctrl+shift+N ’ With Selection If .ShrinkToFit = True Then .ShrinkToFit = False Else .ShrinkToFit = True End If End With

End Sub

Sub センタリング() ’ ’ Keyboard Shortcut: Ctrl+Shift+C ’ With Selection

     If .HorizontalAlignment = xlCenter Then
        .HorizontalAlignment = xlLeft
       Else
        .HorizontalAlignment = xlCenter
     End If

     .VerticalAlignment = xlCenter

End With

End Sub

Sub セル結合() ’ ’ Keyboard Shortcut: Ctrl+Shift+K ’ With Selection

    If .MergeCells = True Then
       .UnMerge
       Else
       .MergeCells = True
    End If

End With

End Sub

Sub インデント右() ’ ’ Keyboard Shortcut: ’ With Selection If .IndentLevel < 15 Then .IndentLevel = .IndentLevel + 1 End If End With End Sub

Sub インデント左() ’ ’ Keyboard Shortcut: ’ With Selection If .IndentLevel > 0 Then .IndentLevel = .IndentLevel - 1 End If End With End Sub

Sub 書式設定_日付() ’ ’ Keyboard Shortcut: Ctrl+t ’ Selection.NumberFormatLocal = “yyyy/mm/dd” End Sub

Sub 周りに罫線() ’ ’ Keyboard Shortcut: Ctrl+Shift+y ‘

If Selection.Borders(xlEdgeTop).LineStyle = xlNone Then
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
Else
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End If

End Sub

Sub 複数ブックまとめる() Dim NewBook As Workbook Dim FileNames As Variant Dim CurIndex As Integer FileNames = Application.GetOpenFilename(FileFilter:=”EXCELファイル(*.xls), *.xls”, MultiSelect:=True) If TypeName(FileNames) = “Boolean” Then Exit Sub For CurIndex = 1 To UBound(FileNames) Workbooks.Open FileNames(CurIndex) With ActiveWorkbook If NewBook Is Nothing Then .Worksheets(1).Copy Set NewBook = ActiveWorkbook Else .Worksheets(1).Copy after:=NewBook.Worksheets(NewBook.Worksheets.Count) End If .Close End With With NewBook .Worksheets(.Worksheets.Count).Name = Left(Dir(FileNames(CurIndex)), Len(Dir(FileNames(CurIndex))) - 4) End With Next End Sub

Sub ExChgCode() Selection.Replace What:=”” & Chr(10) & “”, Replacement:=”” & Chr(11) & “” End Sub

August202009

バルサセスク獲得決定‼

来季だけどね http://m.goal.com/art_1449332?SID=305c10362f3c77b83be651fd16451357

August12009

iPhone OS 3.0.1 Jailbreak 完了♪

iPhone OS 3.0.1 が出たので早速脱獄してみました。

普通に3.0.1 へバージョンアップ
redsn0w を起動し、3.0 のFW を選択して続行
完了

SMS の障害対応だけだから、ベースバンドとかが変更されなかったらしい。

12AM

久々のイタリアン

Antica Vineria Giulianoにて夕食

目黒のLanterna Magica へ行ったけど、満席で入れず

白金へ移動♪ ギリギリ入れて、スプマンテを飲んだ

カプレーゼ、いわしのマリネ、タコとジャガイモのサラダを軽くたいらげ、真鯛のアクアバッツァ、そして、黒トリュフのフィットチーネ(写真のやつ)

美味しかったなぁーと

白ワインと一緒に大変満足でした(^O^)

July232009

tundereforce:

ダ・ヴィンチが残した iPhone の設計図

July192009

ATOK2009 For Mac & Windows

待っていたATOK2009のMac版がやっと届きました

どのOSでもデフォルトの日本語入力ソフトでは満足に使えないので、必ず買うようにしているATOK

今回は5000本限定のMac & Windowsセットを購入。

前のバージョンから大きく変わる事はないものの、変換効率はあがっているのでそれだけでも買いってことになる

文字入力の効率はメール、ドキュメント作成など全ての作業の生産性アップに影響するので、重要な気がする

July172009

Joe - Signature

Joe の最新版を買いました！

1時期作品のできが落ち込んでいたJoe だけど、

前作が結構良いアルバムだったので期待して買ってみた。

出来はかなり良いっす！

全体的に初期のJoe に戻った感じがあって、美メロバラードが炸裂してます

アルバム全体が良いんだけど、その中でお勧めは 2 - 4 曲目の前半バラード群と8-10曲目かなぁ

3と10はJoe の代表作になるのではないかと思います

日本版にはSteppin な感じの曲が1曲と、

おきまりのAll That I am と No One Else Come Close のライブ版が入ってます。

というわけで、超お勧めです！

July152009

Maxwell - BLACKsummer’s night

8年ぶりの新作！期待度MAXで購入しました

中身はと言うと、かなり良い！ Soul 好きにはたまらないと思います 1曲目のBad Habit、6曲目のLove You がお気に入り♪ 全体的に聞き込めるアルバムになっていて、僕的にはこの夏のヘビーチューンにほぼ決定！

このアルバムは実は３部作らしく、本作の【BLACK】そして、【SUMMER】【NIGHT】と 3年かけてリリースされていくらしい

来年も楽しみだなぁーと

July112009

初tumblr

初投稿

今日はMintCondition のライブに行ってくる

その後は焼肉かなぁ

Porc negre

vvf

バルサ セスク獲得決定‼

iPhone OS 3.0.1 Jailbreak 完了♪

初tumblr

バルサセスク獲得決定‼