よく使う関数・罫線

エクセルソフトでよく使う関数

　Option Explicit
'名前定義が存在すれば True 、存在しない場合は False
Function chkNames(chkActiveWorkbook As Workbook, prm_Name As String) As Boolean
    Dim n As Name
    chkNames = False
    For Each n In chkActiveWorkbook.Names
        If n.Name = prm_Name Then
            chkNames = True
            Exit For
        End If
    Next
End Function

Function HkVL(検索番号 As Integer, データ列位置 As Integer, 検索開始行 As Long, 検索シート As String) As Variant
' 生徒番号を入れると、行位置を返す
 Dim R As Range
 Dim 最終行数 As Long
 
 HkVL = 0
 If シートChk(検索シート) Then
    With Worksheets(検索シート)
         最終行数 = .Cells(Rows.Count, データ列位置).End(xlUp).Row - (検索開始行 - 1)
         For Each R In .Cells(検索開始行, データ列位置).Resize(最終行数)
              If R.Value = 検索番号 Then
                 HkVL = R.Row
                 Exit For
              End If
          Next
         
    End With
 End If
End Function

Sub 文字エラーを数字に(myTR As Range)
    Dim セル As Range
    Dim P As Double
    Dim m As Long
    Dim i As Long
    m = myTR.Count
    If m < 1 Then Exit Sub
    MsgBox "作業時間がかかります。" & vbLf & "進行状況はステータスバーに表示します。"
    Application.ScreenUpdating = False
    For Each セル In myTR
        i = i + 1
        Application.StatusBar = "ｴﾗｰﾒｯｾｰｼﾞ(緑三角)を消去中!!--> " & i & " / " & m & " (残り " & Format((1 - i / m), "###.#% ") & ")"
        If セル.Errors.Item(xlNumberAsText).Ignore = False Then
            If IsNumeric(セル) And セル.Value <> "" Then
               セル.Value = Val(StrConv(セル.Value, vbNarrow))  '
            End If
        End If
    Next
  Application.ScreenUpdating = True
 Application.StatusBar = False
 Beep
End Sub

Sub 再計算()
'   Application.ScreenUpdating = False
    Application.Calculate
    Do
      DoEvents
    Loop While Not Application.CalculationState = xlDone
'    Beep
'   Application.ScreenUpdating = True
End Sub

Function myFiC(FileName As String) As Boolean
'    Dim fso As FileSystemObject
'    Set fso = New FileSystemObject ' インスタンス化
    Dim fso As Object
    Dim mM As String
    myFiC = True
    Set fso = CreateObject("Scripting.FileSystemObject")
    On Error GoTo EJob
    
       mM = fso.FileExists(FileName) ' ファイルの存在確認
       Set fso = Nothing
Exit Function
EJob:
    myFiC = False
    Set fso = Nothing
End Function

Function シートChk(strSheetName As String) As Boolean
    Dim objWorksheet As Worksheet
 
    On Error GoTo NotExists
    
    Set objWorksheet = ThisWorkbook.Sheets(strSheetName)
    
    シートChk = True
     Set objWorksheet = Nothing
    Exit Function
NotExists:
    シートChk = False
    Set objWorksheet = Nothing
End Function


Sub 普通罫線(myRang As Range)
'--------------------------------------------
' マクロ記録日 : 2004/12/11  2022 08 16 修正
'--------------------------------------------
  With myRang.Borders
      .LineStyle = xlNone 'クリア
      .LineStyle = xlContinuous  '格子
  End With
End Sub
Sub 両太罫線(myRang As Range)
'------------------------------------------------
' マクロ記録日 : 2004/12/11 2022 08 16 修正
'------------------------------------------------
    myRang.BorderAround Weight:=xlMedium
    
End Sub

Sub 左太罫線(myR As Range)
'------------------------------------------------
'
'------------------------------------------------
    myR.Borders(xlEdgeLeft).Weight = xlMedium


End Sub

Sub 外枠太罫線(myR As Range)
    myR.BorderAround Weight:=xlMedium

End Sub

Sub 下太罫線(myR As Range)
     myR.Borders(xlEdgeBottom).Weight = xlMedium

End Sub

Sub 下普通罫線(myR As Range)
     myR.Borders(xlEdgeBottom).Weight = xlThin
End Sub

Sub 外枠極太罫線(myR As Range)
    myR.BorderAround Weight:=xlThick
End Sub

Sub 罫線削除(myR As Range)
     With myR
         .Borders.LineStyle = xlLineStyleNone
         .Borders(xlDiagonalDown).LineStyle = xlLineStyleNone '右下がり
         .Borders(xlDiagonalUp).LineStyle = xlLineStyleNone   '右上がり
     End With
End Sub



Function Hktrim(myString As String)
  Hktrim = Replace(Replace(myString, " ", ""), "　", "")
  
End Function

Function Get範囲(myR As Range) As String
   
         
      Get範囲 = Replace(myR.Address, "$", "")
      
      
End Function

Function Get生徒数() As Integer
  With Worksheets("基本設定")
       Get生徒数 = WorksheetFunction.CountA(.Range(.Cells(21, 28), .Cells(Rows.Count, 28)))
      
  End With
End Function


Function Get_ID数() As Integer
  With Worksheets("基本設定")
       Get_ID数 = WorksheetFunction.CountA(.Range(.Cells(21, 24), .Cells(Rows.Count, 24)))
      
  End With
End Function



Function Chk罫線(myR As Range) As Boolean
'--------------------------------------
'指定されたセルに罫線があるか true あり false なし
'--------------------------------------
   Dim ls As Variant
   ls = myR.Borders.LineStyle               ' 上下左右の罫線
   ls = myR.Borders(xlEdgeTop).LineStyle    ' 上側の罫線
   ls = myR.Borders(xlEdgeBottom).LineStyle ' 下側の罫線
   ls = myR.Borders(xlEdgeLeft).LineStyle   ' 左側の罫線
   ls = myR.Borders(xlEdgeRight).LineStyle  ' 右側の罫線

   If ls = xlLineStyleNone Then
      Chk罫線 = False
   Else
      Chk罫線 = True
   End If


End Function



Sub 白塗り(myR As Range)
  With myR.Interior
       .ColorIndex = 2
  End With
    
End Sub

Sub 灰塗り(myR As Range)
 With myR.Interior
       .ColorIndex = 15
 End With
    
End Sub

Sub 青塗り(myR As Range)
 With myR.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = 0.399975585192419
        .PatternTintAndShade = 0
    End With

End Sub

Sub 深い青塗り(myR As Range)
 With myR.Interior
        .Color = RGB(47, 117, 181)
 End With
End Sub

Sub 濃い橙塗り(myR As Range)
 With myR.Interior
        .Color = 49407
 End With
End Sub

Sub 肌色塗り(myR As Range)
 With myR.Interior
        .Color = RGB(255, 230, 153)
 End With
End Sub

Sub 紅紫塗り(myR As Range)
   With myR.Interior
        .Color = RGB(180, 76, 151)
   End With
End Sub
 
Sub 淺紫塗り(myR As Range)
   With myR.Interior
        .Color = RGB(196, 163, 191)
 End With
End Sub

Sub みかん塗り(myR As Range)
   With myR.Interior
        .Color = RGB(240, 131, 0)
 End With
End Sub
Sub 女郎花塗り(myR As Range)
   With myR.Interior
        .Color = RGB(242, 242, 176)
 End With
End Sub

Sub 桜色塗り(myR As Range)
   With myR.Interior
        .Color = RGB(254, 244, 244)
 End With
End Sub

Sub 淡紅藤塗り(myR As Range)
   With myR.Interior
        .Color = RGB(230, 205, 227)
 End With
End Sub

Sub 薄紅梅塗り(myR As Range)
   With myR.Interior
        .Color = RGB(229, 151, 178)
 End With
End Sub

Sub 薄橙2塗り(myR As Range)
   With myR.Interior
        .Color = RGB(252, 213, 180)
 End With
End Sub
 
Sub 淡いピンク塗り(myR As Range)
   With myR.Interior
        .Color = RGB(255, 235, 255)
 End With
End Sub

Sub 空色塗り(myR As Range)
   With myR.Interior
        .Color = RGB(197, 216, 239)
 End With
End Sub
 
Sub 塗りRGB(myR As Range, r As Integer, g As Integer, b As Integer)
    With myR.Interior
        .Color = RGB(r, g, b)
 End With
End Sub

Sub 塗り16(myR As Range, H16 As String)
    With myR.Interior
        .Color = Val("&h" & H16)
 End With
End Sub

Sub セル結合HCVC(myR As Range)
    With myR
         Application.DisplayAlerts = False
         .MergeCells = True
        Application.DisplayAlerts = True
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
     End With
End Sub

Sub セル結合HLVC(myR As Range)
    With myR
         Application.DisplayAlerts = False
         .MergeCells = True
        Application.DisplayAlerts = True
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
     End With
End Sub

Sub セル結合HLVT(myR As Range)
    With myR
         Application.DisplayAlerts = False
         .MergeCells = True
        Application.DisplayAlerts = True
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
     End With
End Sub


Sub GetRGBValue(lColorValue, Red, Green, Blue)
    Red = lColorValue Mod 256
    Green = Int(lColorValue / 256) Mod 256
    Blue = Int(lColorValue / 256 / 256)
    
    Debug.Print "赤：" & Red
    Debug.Print "緑：" & Green
    Debug.Print "青：" & Blue
    Debug.Print Hex(lColorValue)
End Sub

Sub 色調査()
   Dim r
   Dim g
   Dim b
   Call GetRGBValue(ActiveCell.Interior.Color, r, g, b)
End Sub

Function ConvertToLetter(iCol As Long) As String
'列番号を列名に変換
   Dim a As Long
   Dim b As Long
   a = iCol
   ConvertToLetter = ""
   Do While iCol > 0
      a = Int((iCol - 1) / 26)
      b = (iCol - 1) Mod 26
      ConvertToLetter = Chr(b + 65) & ConvertToLetter
      iCol = a
   Loop
End Function

Function Get列名(myR As Range) As String
  'レンジ範囲の先頭列名を取得
  Get列名 = Split(myR.Address(True, False), "$")(0)

End Function



Function Getふりがな(myR As Range) As String
     Getふりがな = StrConv(Application.GetPhonetic(myR.Value), vbHiragana)
        
End Function


Function myLeft(Target As Range) As Long
'---------------------------------------
'セルのレフト位置
'---------------------------------------
 Dim R1C1Left As Long
 Const DPI As Long = 96
 Const PPI As Long = 72
    
  With ActiveWindow
    R1C1Left = .PointsToScreenPixelsX(0)
    myLeft = (((Target.Left * (DPI / PPI)) * (.Zoom / 100)) + R1C1Left) * (PPI / DPI)
    
  End With


End Function

Function myTop(Target As Range) As Long
'---------------------------------------
'セルのトップ位置
'---------------------------------------
  Dim R1C1Top As Long
  Dim UF_Top As Long
  Const DPI As Long = 96
  Const PPI As Long = 72
    
  With ActiveWindow
    R1C1Top = .PointsToScreenPixelsY(0)
    myTop = (((Target.Top * (DPI / PPI)) * (.Zoom / 100)) + R1C1Top) * (PPI / DPI)
  End With
End Function

Sub FormALLClose1()

Dim MyForm As Object

For Each MyForm In UserForms
   On Error Resume Next
    Unload MyForm
   On Error GoTo 0
Next

End Sub

Sub 画面固まり解除()

   DoEvents
   With Application
       .EnableEvents = True
       DoEvents
       .CalculateFullRebuild
       DoEvents
       .Calculation = xlCalculationAutomatic
        DoEvents
       .ScreenUpdating = True
        DoEvents
       .ScreenUpdating = True
       
   End With
   DoEvents
   DoEvents
   
End Sub


Sub GetMyName()
'---------------------------------------
'バージョンＵＰ時にファイル名と日付を取得
'---------------------------------------
    Rows(7).Insert
     Call 白塗り(Range("B7:D7"))
     
    Range("b7") = ActiveWorkbook.Name
    Range("c7") = Format(Date, "yyyy/mm/dd")
    Call 普通罫線(Range("B6:D7"))
End Sub

Sub 条件付き書式job(レンジ As Range, 順番 As Integer, 式 As String, 色 As Long, StopSW As Boolean)
'
' 使い方
'
'  条件付き書式を加える範囲 myR
'  対象列名 = Split(myR.Address(True, False), "$")(0)
'  これで式をつくる最初の列範囲を取得
'
'　式 = "=or(" & 対象列名 & "9=""a""," & 対象列名 & "9=""A"")"
'            Call 条件付き書式job(myR, 1, 式, A_Co, True)
'
'　式 = "=AND(" & 対象列名 & "9<" & 対象列名 & "$4," & 対象列名 & "9>=" & 対象列名 & "$5)"
'　　　　　　 Call 条件付き書式job(myR, 2, 式, N_Co(4), True)
'
'  のように式ををつくり，このサブルーチンを呼ぶ。順番は条件の順番
'
'  条件付き書式をaddする前に
'　　.Cells.FormatConditions.Delete '条件付き書式の削除をしておく
'
'
    With レンジ
        .FormatConditions.Add Type:=xlExpression, Formula1:=式
        .FormatConditions(順番).Font.Color = 色
        .FormatConditions(順番).StopIfTrue = StopSW
    End With

End Sub