スポンサーリンク

エクセルマクロのロジックメモ

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

'**
'* 別ファイルのシートをコピー
'*
'* @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

    dataANSI = StrConv(data, vbFromUnicode)
    dataLen = Len(data)
    dataLenB = LenB(dataANSI)

    If (dataLen * 2) = dataLenB Then
        judgementFullHalfWidth = 1
    ElseIf dataLen = dataLenB Then
        judgementFullHalfWidth = 2
    Else
        judgementFullHalfWidth = 3
    End If

End Function

タイトルとURLをコピーしました