Office

エクセルマクロの独立処理関数

  /
Contents
  1. 別のエクセルからシートをコピー
  2. CSVファイル読込
  3. シート名存在チェック
  4. マスタシートでキーを検索して、データを取得
  5. マスタ存在チェック
  6. バリデートチェック
  7. 全角半角判定
  8. 全角カナを半角カナに変換
  9. ファイル出力

別のエクセルからシートをコピー

'**
'* 別ファイルのシートをコピー
'*
'* @param string fileName ファイル名
'* @param string sheetName シート名
'* @return void
'**
Sub copyNewUserSheet(fileName As String, SheetName As String)
    fileName = ThisWorkbook.Path & "\" & fileName

    'コピーするシート名と同じ名前のシートがあれば削除
    '※IsExistWorksheetは別関数なので注意
    If IsExistWorksheet(SheetName) Then
        Application.DisplayAlerts = False
        Sheets(SheetName).Delete
        Application.DisplayAlerts = True
    End If

    '読み込むファイルが存在しない場合はエラー
    If Dir(fileName) = "" Then
        MsgBox ("ファイルがありません。ファイル名：" & fileName)
        End
    End If
        'ファイルを開く
    Workbooks.Open fileName
    'シートを一番後ろにコピー
    Worksheets(SheetName).Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
    'ファイルを保存しないで閉じる
    Workbooks(Dir(fileName)).Close savechanges:=False
    '元のシートをアクティブにする
    Sheets("Sheet1").Activate
End Sub

CSVファイル読込

'------------------------
'CSV読込
'------------------------
Function readCsvUser(fileName As String)
    Dim ws As Worksheet

    'ファイルがない場合はエラー
    If Dir(ThisWorkbook.Path & "\" & fileName) = "" Then
        MsgBox ("ファイルがありません。")
        End
    End If

    '古いシートを削除
    If (IsExistWorksheet(workSheetName)) Then
        Application.DisplayAlerts = False
        Sheets(workSheetName).Delete
        Application.DisplayAlerts = True
    End If

    'CSV読込（外部モジュール）
    Set ws = ReadCSV.ReadCSV(Filepath:=ThisWorkbook.Path & "\" & fileName, _

TextColumns:="1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24
,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49"
)
    'シート名変更、移動
    ws.name = workSheetName
    Worksheets(workSheetName).Move After:=Worksheets("Sheet1")
End Function

シート名存在チェック

'------------------------
'シート名存在チェック
'------------------------
Function IsExistWorksheet(name As String)
    Dim ws As Worksheet
    For Each ws In Sheets
        If ws.name = name Then
            IsExistWorksheet = True
            Exit Function
        End If
    Next

    IsExistWorksheet = False
End Function

マスタシートでキーを検索して、データを取得

'**
'* ユーザーの部署IDから名称を取得
'*
'* @param string deptId 部署ID
'* @return string 部署名
'**
Function getDeptName(deptId As String) As String
    deptName = ""

    'マスタシートをアクティブにする
    Sheets(sheetNameDeptMaster).Activate

    'マスタの最終行を取得
    masterLastRow = Range("A1").End(xlDown).Row

    '検索対象列をループ
    For i = 1 To masterLastRow
        If Cells(i, 1) = deptId Then
            '取得対象列を返却
            deptName = Cells(i, 2)
        End If
    Next

    getDeptName = deptName
    'メインシートをアクティブにする
    Sheets(sheetNameMain).Activate

End Function

マスタ存在チェック

'マスタ存在チェック
Dim master As Range
Dim search As Range
Dim masterLastRow As Integer
'マスタの最終行を取得
masterLastRow = Range("B1").End(xlDown).Row
'マスタの検索範囲を設定
Set master = Sheets("マスタA").Range("B3:B" & masterLastRow)
'完全一致で検索（部分一致の場合は「xlPart」）
Set search = master.Find(data, LookAt:=xlWhole)

'有無の判定
If search Is Nothing Then
    MsgBox (search.Row)
End If

バリデートチェック

'------------------------
'ログインIDチェック
'------------------------
Function validateLoginId(data As String)
    '値存在チェック
    If (data = "") Then
        '値なし
        Exit Function
    End If
    '桁数チェック
    If Len(data) <> 7 Then
        '桁数エラー
        Exit Function
    End If

    '数字8桁チェック
    If Len(abcdef) <> 8 Or Not IsNumeric(abcdef) Then
        '数値8桁以外の場合はエラーです
    End If
End Function

全角半角判定

'------------------------
'全角、半角チェック
'1:全角、2:半角、3:両方ある
'------------------------
Function judgementFullHalfWidth(data As String) As Integer
    Dim dataLen As Integer
    Dim dataLenB As Integer

    'ANSI文字列に変換、半角英数字は1バイト、全角は2バイトになる
    dataANSI = StrConv(data, vbFromUnicode)
    '文字数を取得
    dataLen = Len(data)
    'バイト数を取得
    dataLenB = LenB(dataANSI)

    '全て2バイト文字か、全て1バイト文字か、混在しているかで判定
    If (dataLen * 2) = dataLenB Then
        judgementFullHalfWidth = 1
    ElseIf dataLen = dataLenB Then
        judgementFullHalfWidth = 2
    Else
        judgementFullHalfWidth = 3
    End If

End Function

全角カナを半角カナに変換

'**
'* 全角カナを半角カナに変換
'*
'* @param string fullKana 全角カナ
'* @return string 半角カナ
'**
Function replaceFullKanaToHalfKana(fullKana As String) As String

    replaceFullKanaToHalfKana = fullKana

    '変換文字の対比表
    fromList = "　,ア,イ,ウ,エ,オ,カ,キ,ク,ケ,コ,サ,シ,ス,セ,ソ,タ,チ,ツ,テ,ト,ナ,ニ,ヌ,ネ,ノ,ハ,ヒ,フ,ヘ,ホ,マ,ミ,ム,メ,モ,ヤ,ユ,ヨ,ラ,リ,ル,レロ,ワ,ヲ,ン,ァ,ィ,ゥ,ェ,ォ,ッ,ャ,ュ,ョ,ー,ガ,ギ,グ,ゲ,ゴ,ザ,ジ,ズ,ゼ,ゾ,ダ,ヂ,ヅ,デ,ド,バ,ビ,ブ,ベ,ボ,パ,ピ,プ,ペ,ポ,ヴ"
    toList = " ,ｱ,ｲ,ｳ,ｴ,ｵ,ｶ,ｷ,ｸ,ｹ,ｺ,ｻ,ｼ,ｽ,ｾ,ｿ,ﾀ,ﾁ,ﾂ,ﾃ,ﾄ,ﾅ,ﾆ,ﾇ,ﾈ,ﾉ,ﾊ,ﾋ,ﾌ,ﾍ,ﾎ,ﾏ,ﾐ,ﾑ,ﾒ,ﾓ,ﾔ,ﾕ,ﾖ,ﾗ,ﾘ,ﾙ,ﾚﾛ,ﾜ,ｦ,ﾝ,ｧ,ｨ,ｩ,ｪ,ｫ,ｯ,ｬ,ｭ,ｮ,ｰ,ｶﾞ,ｷﾞ,ｸﾞ,ｹﾞ,ｺﾞ,ｻﾞ,ｼﾞ,ｽﾞ,ｾﾞ,ｿﾞ,ﾀﾞ,ﾁﾞ,ﾂﾞ,ﾃﾞ,ﾄﾞ,ﾊﾞ,ﾋﾞ,ﾌﾞ,ﾍﾞ,ﾎﾞ,ﾊﾟ,ﾋﾟ,ﾌﾟ,ﾍﾟ,ﾎﾟ,ｳﾞ"

    '配列形式に変換
    arrFromList = Split(fromList, ",")
    arrToList = Split(toList, ",")

    '変換配列をループして変換対象を置換する
    For i = 0 To UBound(arrFromList) - 1
        replaceFullKanaToHalfKana = Replace(replaceFullKanaToHalfKana, arrFromList(i), arrToList(i))
    Next

End Function

ファイル出力

'**
'* ファイル出力
'*
'* @param string word 出力する文字
'* @return void
'**
Function outText(word As String)

    Dim datFile As String
    datFile = ActiveWorkbook.Path & "\data.txt"

    Open datFile For Output As #1
    Print #1, word
    Close #1

End Function

ABOUT ME
hazukei
「はずけい」と申します。 この度一児の父となりました。まだ実感はわかないのですが、猛烈に忙しくなりそうです。楽しみつつ頑張りたいと思います！
BLOG：https://hazukei.com/
RELATED POST