ユーザー定義関数 索引数取得

'''
''''カスタム関数　索引数取得
'''
'''Function 索引数取得(引数 As Range) As Variant
'''
''''    Dim 引数 As Range
''''    Set 引数 = Application.ThisCell
'''
'''    '=IF(IsHidden([@五十音]),"",索引数取得)
'''    '=IF(IsHidden([@五十音]),"",IF(OFFSET([@五十音],-1,)=[@五十音],"",COUNTIF([五十音],[@五十音])))
'''
'''If 索引数辞書.Count = 0 Then 索引数辞書 = Nothing
''''Debug.Print Join(索引数辞書.Items, ",")
'''    Debug.Print 索引数辞書.Count 'Join(索引数辞書.Items, ",")
'''    If 索引数辞書 Is Nothing Then
'''        Call 索引数辞書編纂
'''    End If
'''
'''    If InStr(索引数辞書.Item(引数.Value), 引数.Address) Then
'''        索引数取得 = Split(索引数辞書.Item(引数.Value), ",")(1)
'''        索引数辞書.Remove 引数.Value
'''    Else
'''        索引数取得 = ""
'''    End If
'''
''''    索引数辞書 = Nothing
'''
'''End Function

'カスタム関数　索引数取得
Function 索引数取得2() As String

''''''    Dim フィールド As Range
''''''    Set フィールド = Range("売場案内T2OutputQueryTable[五十音]").SpecialCells(xlCellTypeVisible)
''''''    Set フィールド = ActiveSheet.ListObjects(2).AutoFilter.Range.Columns(3).SpecialCells(xlCellTypeVisible) '20220617
''''''    Debug.Print フィールド.Cells.Count
'''''''    =IF(IsHidden([@五十音]),"",IF(OFFSET([@五十音],-1,)=[@五十音],"",COUNTIF([五十音],[@五十音])))
''''''    Call 索引数辞書編纂
''''''Exit Function
''''''
''''''    For Each レコード In フィールド
''''''
''''''        If InStr(索引数辞書.Item(レコード.Value), レコード.Address) Then
''''''            Debug.Print フィールド.Address
'''''''            Split(索引数辞書.Item(引数.Value), ",")(1)
''''''            索引数辞書.Remove 引数.Value
''''''        Else
''''''            索引数取得 = ""
''''''        End If
''''''
''''''    Next
    
'    Debug.Print フィールド.Address
''    Debug.Print 連番 & "v:" & フィールド.SpecialCells(xlCellTypeVisible).Cells(1).Value
'    Debug.Print フィールド.SpecialCells(xlCellTypeVisible).Cells(1).Address
'    Debug.Print フィールド.SpecialCells(xlCellTypeVisible).Cells(2).Offset(-1).Address
'    Debug.Print "─────────────────────────────"
    
'    '最初のセルがデータ領域の先頭か否か
'    If 引数.Row = フィールド.Cells(1).Row Then
'        Debug.Print "1:" & WorksheetFunction.CountIf(Range(フィールド.Address), 引数.Value)
'    Else
''        If 引数.(-1).Value = 引数.Value Then
''            Debug.Print "none"
''        Else
''            Debug.Print "2:" & WorksheetFunction.CountIf(Range(フィールド.Address), 引数.Value)
''        End If
'    End If
    
'    索引数取得2 = ""
    
'
'    Debug.Print フィールド.Cells.Count
'    Debug.Print フィールド.SpecialCells(xlCellTypeVisible).Cells.Count
'    Debug.Print フィールド.Address
'
''''''    If 索引数辞書 Is Nothing Then
''''''    Call 索引数辞書編纂
''''''    End If
''''''    Debug.Print Join(索引数辞書.Items, ",")
'
'    Set 索引数辞書 = Nothing

End Function

Excel テーブル ListObjects 関数だけで不可視か否か

関数だけサブトータル１　可視を１からカウント

SUBTOTAL(3,INDIRECT(ADDRESS(ROW([BMN]),COLUMN([BMN]))):INDIRECT(ADDRESS(ROW([@BMN]),COLUMN([@BMN]))))

関数だけサブトータル２　可視を０からカウント

SUBTOTAL(3,INDIRECT(ADDRESS(ROW([BMN]),COLUMN([BMN]))):INDIRECT(ADDRESS(ROW([@BMN])-1,COLUMN([@BMN]))))

関数だけサブトータル１　-　関数だけサブトータル２　= 可視は1　: 不可視は0

SUBTOTAL(3,INDIRECT(ADDRESS(ROW([BMN]),COLUMN([BMN]))):INDIRECT(ADDRESS(ROW([@BMN]),COLUMN([@BMN]))))-SUBTOTAL(3,INDIRECT(ADDRESS(ROW([BMN]),COLUMN([BMN]))):INDIRECT(ADDRESS(ROW([@BMN])-1,COLUMN([@BMN]))))

↑
関数だけVBAで確認

.Sub test()
    For Each cell In Range("a2:a33")
       Debug.Print cell.Row & ":" & cell.Offset(0, 3) & ":" & cell.EntireRow.Hidden
    Next
End Sub.

■■■　ユーザー定義がイケるなら　■■■

'ユーザー定義関数　不可視行が否か
Function IsHidden(セル As Range) As Boolean

    IsHidden = セル.EntireRow.Hidden

End Function

VBA Excel 売場案内 範囲選択

Function 売場案内マスター入力項目範囲(Optional 引数 As String) As Range '範囲選択　画面（シート）移動在り

    'リストのシートを指定
    Dim WsListMaster As Worksheet
    Set WsListMaster = Worksheets("売場案内.マスター")
       
    WsListMaster.Activate

    'リストのカレント範囲
    Dim i As Long
    i = Application.WorksheetFunction.Max(WsListMaster.Cells(60000, 1).End(xlUp).Row, WsListMaster.Cells(60000, 2).End(xlUp).Row, WsListMaster.Cells(60000, 3).End(xlUp).Row)
    Dim tbl As Range
    Set tbl = WsListMaster.Range(Cells(1, 1), Cells(i, 3)).CurrentRegion
    'Set tbl = tbl.Resize(i - 2, 7).Offset(2) '入力項目にリサイズ
    Set tbl = tbl.Resize(i - 2, 1).Offset(2) '入力項目の一列目にリサイズ
   
    tbl.Select
    
    If 引数 = "return" Then
        Set 売場案内マスター入力項目範囲 = tbl.SpecialCells(xlCellTypeVisible) '戻り値
    End If

End Function

VBA Excel テーブルの並び替えの判定 sort 有無

For Each Table In Me.ListObjects
    If ListObjects(Table.Name).Sort.SortFields.Count Then
        Debug.Print ListObjects(Table.Name).Sort.SortFields.Count
    End If
Next Table

VBA Excel ウェブサイトを開く URLを開く

Private Sub CommandButton1_Click()
    Call マイクロソフトサポートデータフォームについてをブラウザで開く
End Sub

Function マイクロソフトサポートデータフォームについてをブラウザで開く()

    Dim res As Variant
    res = MsgBox("マイクロソフトのサポートページ" & vbNewLine & vbNewLine & _
    "データ フォームを使用して行を追加、編集、検索、および削除する" & vbNewLine & vbNewLine & _
    "をインターネットブラウザーで表示しますか" & vbNewLine _
    , vbYesNo + vbInformation + vbDefaultButton2, "データフォームについて")
    
    If res = vbYes Then
    
        CreateObject("Shell.Application").ShellExecute "microsoft-edge:https://support.microsoft.com/ja-jp/office/%E3%83%87%E3%83%BC%E3%82%BF-%E3%83%95%E3%82%A9%E3%83%BC%E3%83%A0%E3%82%92%E4%BD%BF%E7%94%A8%E3%81%97%E3%81%A6%E8%A1%8C%E3%82%92%E8%BF%BD%E5%8A%A0-%E7%B7%A8%E9%9B%86-%E6%A4%9C%E7%B4%A2-%E3%81%8A%E3%82%88%E3%81%B3%E5%89%8A%E9%99%A4%E3%81%99%E3%82%8B-17bca0a4-3ba5-444a-983c-a8ce70609374"
    
    End If
    
    If res = vbNo Then
        '終了
    End If

End Function

VBA Excel 文字列の全角、半角、混合を判別する

'全て半角に変換する場合
    Dim strANSI     As String
    Dim myLen       As Integer
    Dim myLenB      As Integer
    Dim strUnicode  As String

    strUnicode = Application.WorksheetFunction.Asc(通路番号情報)

    If strUnicode = "" Then
        通路番号分解 = ""
        Exit Function
    End If

    strANSI = StrConv(strUnicode, vbFromUnicode)

    myLen = Len(strUnicode)
    myLenB = LenB(strANSI)

'    '半角カナを全角カナにコンバート
'    If LenB(StrConv(strUnicode, vbHiragana)) - myLenB > 0 Then
'        'Debug.Print "半角カナが混じっています"
'        strUnicode = 半角カナを全角カナに変える(strUnicode)
'        strANSI = StrConv(strUnicode, vbFromUnicode)
'        myLen = Len(strUnicode)
'        myLenB = LenB(strANSI)
'    End If

    If myLen * 2 = myLenB Then
        'Debug.Print "全角文字だけです"
        通路番号分解 = strUnicode
    ElseIf myLen = myLenB Then
        'Debug.Print "半角文字だけです"
        通路番号分解 = strUnicode
    Else
        'Debug.Print "全角と半角が混じっています"
        If strUnicode Like "[A-Z.a-z 0-9]*" Then
            通路番号分解 = 文字列から英数字以外を削除する(strUnicode)
            Else
            通路番号分解 = strUnicode
        End If
    End If

VBA Excel カタカナだけを判別してwideとnarrowに変換する

カタカナが含まれていれば全角カナに変更する

文字列 = StrConv(文字列, vbWide) 'JIS全角にする
If StrConv(文字列, vbHiragana) <> 文字列 Then
	文字列 = 半角カナを全角カナに変える(StrConv(文字列, vbNarrow))
End If

カタカナが含まれていれば半角カナに変更する

文字列 = StrConv(文字列, vbWide) 'JIS全角にする
If StrConv(文字列, vbHiragana) <> 文字列 Then
	文字列 = 全角カナを半角カナに変える(StrConv(文字列, vbNarrow))
End If

Function 半角カナを全角カナに変える(文字列 As String) As String

    Dim キャラクタ As String
    
    Dim Likeパターン As String
    Dim インクリメント As Integer
    
    Likeパターン = "[ｱｲｳｴｵｶｷｸｹｺｻｼｽｾｿﾀﾁﾂﾃﾄﾅﾆﾇﾈﾉﾊﾋﾌﾍﾎﾏﾐﾑﾒﾓﾔﾕﾖﾗﾘﾙﾚﾛﾜｦﾝｧｨｩｪｫｯｬｭｮﾞﾟｰ]"
    戻り値 = ""
    
    For インクリメント = 1 To Len(文字列)
        キャラクタ = Mid(文字列, インクリメント, 1)
        If キャラクタ Like Likeパターン Then
            戻り値 = 戻り値 & StrConv(キャラクタ, vbWide)
        Else
            戻り値 = 戻り値 & キャラクタ
        End If
    Next
    
    半角カナを全角カナに変える = 戻り値

End Function

Function 全角カナを半角カナに変える(文字列 As String) As String

    Dim キャラクタ As String
    
    Dim Likeパターン As String
    Dim インクリメント As Integer
    
    Likeパターン = "[ｱｲｳｴｵｶｷｸｹｺｻｼｽｾｿﾀﾁﾂﾃﾄﾅﾆﾇﾈﾉﾊﾋﾌﾍﾎﾏﾐﾑﾒﾓﾔﾕﾖﾗﾘﾙﾚﾛﾜｦﾝｧｨｩｪｫｯｬｭｮﾞﾟｰ]"
    戻り値 = ""
    
    For インクリメント = 1 To Len(文字列)
        キャラクタ = Mid(文字列, インクリメント, 1)
        If キャラクタ Like Likeパターン Then
            戻り値 = 戻り値 & キャラクタ
        Else
            戻り値 = 戻り値 & StrConv(キャラクタ, vbWide)
        End If
    Next
    
    全角カナを半角カナに変える = 戻り値

End Function

VBA Excel 条件付き書式のルールをマクロで作成 数式で行を塗りつぶす

条件付き書式のルールをマクロで一気に流し込む

肝は、良い感じのカラーインデックスをルールの数だけ配列に入れる。繰り返しは減算のデクリメントで数式の数値が大きい順番になるように指定。ルールの番号はインクリメントで指定。カラーインデックス配列のアイテム番号はもインクリメントで指定してみた。配色は使い捨てのシートなのでテキトーに選んでる。

• arrColorIndex = Array(34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55)
• For d = UBound(arrColorIndex) To 1 Step -1
• xlExpression, Formula1:="=IF(AND(ISNUMBER($G1),$G1>=" & d * 100 & ")

注意：このマクロは既存のルールを削除するので、テストは　.FormatConditions.Delete　をコメント化してやる

画像シート

マクロはシートモジュールに書いといた（マクロの記録をいじった）

Private Sub 条件付き書式設定()
Dim d As Long
Dim i As Long
i = 1
Dim arrColorIndex As Variant
arrColorIndex = Array(34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55)
    With Me.Range("$A:$H")
        .FormatConditions.Delete
        For d = UBound(arrColorIndex) To 1 Step -1
            .FormatConditions.Add Type:=xlExpression, Formula1:="=IF(AND(ISNUMBER($G1),$G1>=" & d * 100 & "),TRUE,FALSE)"
            With .FormatConditions(i).Borders(xlLeft)
                .LineStyle = xlContinuous
                .ThemeColor = 1
                .TintAndShade = -0.249946592608417
                .Weight = xlThin
            End With
            With .FormatConditions(i).Borders(xlRight)
                .LineStyle = xlContinuous
                .ThemeColor = 1
                .TintAndShade = -0.249946592608417
                .Weight = xlThin
            End With
            With .FormatConditions(i).Borders(xlTop)
                .LineStyle = xlContinuous
                .ThemeColor = 1
                .TintAndShade = -0.249946592608417
                .Weight = xlThin
            End With
            With .FormatConditions(i).Borders(xlBottom)
                .LineStyle = xlContinuous
                .ThemeColor = 1
                .TintAndShade = -0.249946592608417
                .Weight = xlThin
            End With
            With .FormatConditions(i).Interior
                .PatternColorIndex = xlAutomatic
                .ColorIndex = arrColorIndex(d)
                .TintAndShade = 0.599981688894314
            End With
            i = i + 1
        Next
    End With
End Sub

画像ルール

画像ルール書式

VBA ユーザー定義関数 Split(文字列,区切り値,取り出す配列番号)

'カスタム関数　Split(文字列,区切り値,取り出す配列番号)
Function hSeparate(ByRef str As String, ByRef sep As String, Optional ByRef lmt As String) As Variant
    Dim v As Variant
    If lmt Then
    v = Split(str, sep)(lmt)
    Else
    v = Split(str, sep)
    End If
    hSeparate = v
End Function

エクセルVBA カタカナをひらがなにする

StrConv(strUnicode, vbHiragana)

Office TANAKA - Excel VBA関数[StrConv]

通路番号分解 文字列が半角、全角、混在かを判断する

=IF(LEN(ASC(D3))=LENB(ASC(D3)),ASC(D3),文字列から英数字以外を削除する(D3))

'カスタム関数　通路番号を分解する
'=IF(LEN(ASC(D3))=LENB(ASC(D3)),ASC(D3),文字列から英数字以外を削除する(D3))
'=IF(LEN(ASC(C3))=LENB(ASC(C3)),ASC(C3),IF(LEN(ASC(C3))*2=LENB(ASC(C3)),ASC(C3),文字列から英数字以外を削除する(C3)))
Function 通路番号分解(通路番号情報 As String) As String

    Dim strANSI     As String
    Dim myLen       As Integer
    Dim myLenB      As Integer
    Dim strUnicode  As String
    
    strUnicode = 通路番号情報
    
    strANSI = StrConv(strUnicode, vbFromUnicode)
    
    myLen = Len(strUnicode)
    myLenB = LenB(strANSI)
    
    If myLen * 2 = myLenB Then
        Debug.Print "全角文字だけです"
        通路番号分解 = Application.WorksheetFunction.JIS(通路番号情報)
    ElseIf myLen = myLenB Then
        Debug.Print "半角文字だけです"
        通路番号分解 = Application.WorksheetFunction.Asc(通路番号情報)
    Else
        Debug.Print "全角と半角が混じっています"
        通路番号分解 = 文字列から英数字以外を削除する(通路番号情報)
    End If
    
End Function

'カスタム関数　文字列から英数字以外を削除する(セル)　文字列から英数字以外を削除する
Function 文字列から英数字以外を削除する(文字列 As String) As String

    Dim 戻り値 As String
    Dim キャラクタ As String
    
    Dim Likeパターン As String
    Dim インクリメント As Integer
    
    Likeパターン = "[A-Z.a-z 0-9]"
    戻り値 = ""
    
    For インクリメント = 1 To Len(文字列)
        キャラクタ = Mid(文字列, インクリメント, 1)
        If キャラクタ Like Likeパターン Then
            戻り値 = 戻り値 & キャラクタ
        End If
    Next
    
    文字列から英数字以外を削除する = 戻り値
    
End Function

Excel VBA を学ぶなら moug モーグ | 即効テクニック | 文字列が半角、全角、混在かを判断する

VBA 文字列から英数字以外を削除する

=IF(LEN(ASC(D3))=LENB(ASC(D3)),ASC(D3),文字列から英数字以外を削除する(D3))

'カスタム関数　文字列から英数字以外を削除する(セル)　文字列から英数字以外を削除する
Function 文字列から英数字以外を削除する(文字列 As String) As String

    Dim 戻り値 As String
    Dim キャラクタ As String
    
    Dim Likeパターン As String
    Dim インクリメント As Integer
    
    Likeパターン = "[A-Z.a-z 0-9]"
    戻り値 = ""
    
    For インクリメント = 1 To Len(文字列)
        キャラクタ = Mid(文字列, インクリメント, 1)
        If キャラクタ Like Likeパターン Then
            戻り値 = 戻り値 & キャラクタ
        End If
    Next
    
    文字列から英数字以外を削除する = 戻り値
    
End Function