VBAツール ※この記事は個人的な備忘録です

はじめに

• この記事は個人的な備忘録です。
• 業務で使用するためのサンプルツール用のコードなどを記述します。書きかけのコードもあります。
• あくまでサンプルのため、コードの実践は自己責任でお願いします。

概要

転記ツール

'[Module1]
Enum header
    旧型番 = 1
    旧製品名
    旧受注停止日
    旧出荷停止日
    新型番
    新製品名
    新受注停止日
    新出荷停止日
    製品名
    掲載順判定
End Enum

Sub 掲載用販売停止情報作成()

    Call 新型番表シート.最終行確認
    Call 旧型番表シート.配列作成
    Call 掲載順シート.最終行確認
    Call 掲載用_販売停止情報シート.最終行確認
    
    Call 対象外型番判定

    Call 販売停止情報転記
    Call 掲載順整理
    
    Call 掲載用_販売停止情報シート.セル結合
    Call 掲載用_販売停止情報シート.製品名挿入

End Sub

Function 旧製品名検索一致(ByVal i As Long) As String

    Dim j As Long
    For j = 2 To UBound(旧型番表シート.配列, 1)
        If 新型番表シート.Cells(i, 11).Value = 旧型番表シート.配列(j, 1) Then
            旧製品名検索一致 = 旧型番表シート.配列(j, 3)
        End If
    Next j

End Function


Function 掲載順置換(ByVal i As Long) As String

    Dim order As String
    Dim j As Long
    For j = 2 To 掲載順シート.最終行_製品名
        
        If Left(新型番表シート.Cells(i, 11).Value, 6) = 掲載順シート.Cells(j, 1).Value Then
            order = 掲載順シート.Cells(j, 3).Value
        End If
    Next j
    
    order = order & "_" & 新型番表シート.Cells(i, 9).Value
    
    For j = 2 To 掲載順シート.最終行_分類
        If 新型番表シート.Cells(i, 2).Value = 掲載順シート.Cells(j, 4).Value Then
            order = order & "_" & 掲載順シート.Cells(j, 5).Value
        End If
    Next j

    掲載順置換 = order

End Function

Sub 対象外型番判定()

    Dim i As Long
    For i = 2 To 新型番表シート.最終行
        If Mid(新型番表シート.Cells(i, 1).Value, 4, 1) = "P" Then
            MsgBox 新型番表シート.Cells(i, 1).Value & "はPシリーズ製品です。処理を中止するので" & i & "行目を削除してください。"
            Exit Sub
        ElseIf 新型番表シート.Cells(i, 11) = "-" Then
            MsgBox 新型番表シート.Cells(i, 1).Value & "は前バージョンがない製品です。処理を中止するので" & i & "行目を削除してください。"
            Exit Sub
        End If
    Next i

End Sub

Sub 販売停止情報転記()


    Dim num As Long  '販売停止情報シートのカウンタ関数
    num = 1
    
    Dim i As Long
    For i = 2 To 新型番表シート.最終行
        num = num + 1
        With 販売停止情報シート
            .Cells(num, header.旧型番).Value = 新型番表シート.Cells(i, 11).Value
            .Cells(num, header.旧製品名).Value = 旧製品名検索一致(i)
            .Cells(num, header.旧受注停止日).Value = 旧製品受注出荷停止日シート.Cells(2, 1).Value
            .Cells(num, header.旧出荷停止日).Value = 旧製品受注出荷停止日シート.Cells(2, 2).Value
            .Cells(num, header.新型番).Value = 新型番表シート.Cells(i, 1).Value
            .Cells(num, header.新製品名).Value = 新型番表シート.Cells(i, 3).Value
            .Cells(num, header.新受注停止日).Value = 新型番表シート.Cells(i, 7).Value
            .Cells(num, header.新出荷停止日).Value = 新型番表シート.Cells(i, 8).Value
            .Cells(num, header.製品名).Value = 製品名抽出(i)
            .Cells(num, header.掲載順判定).Value = 掲載順置換(i)
        End With
    Next i

End Sub

Function 製品名抽出(ByVal i As Long) As String

    Dim j As Long
    For j = 2 To 掲載順シート.最終行_製品名
        If Left(新型番表シート.Cells(i, 11).Value, 6) = 掲載順シート.Cells(j, 1).Value Then
               製品名抽出 = 掲載順シート.Cells(j, 2).Value
        End If
    Next j

End Function

Sub 掲載順整理()

    Dim 転記範囲 As Range
    Set 転記範囲 = 販売停止情報シート.Range("A1").CurrentRegion
    
    With 転記範囲
        .Sort Key1:=.Range("J1"), Order1:=xlAscending, header:=xlYes
        .Resize(.Rows.Count - 1).Offset(1, 0).Copy
    End With
    
    掲載用_販売停止情報シート.Range("B9").PasteSpecial Paste:=xlPasteValues
    
End Sub

[旧型番表シート]
Public 配列 As Variant

Sub 配列作成()
　　配列 = Cells(1, 1).CurrentRegion.Value
End Sub

[掲載順シート]
Public 最終行_製品名 As Variant
Public 最終行_分類 As Variant

Sub 最終行確認()    
    最終行_製品名 = Cells(Rows.Count, 1).End(xlUp).Row
    最終行_分類 = Cells(Rows.Count, 4).End(xlUp).Row
End Sub

[掲載用_販売停止情報シート]
Public 最終行 As Long

Sub 最終行確認()
　　最終行 = Cells(Rows.Count, 2).End(xlUp).Row
End Sub

Sub セル結合()
    Call 最終行確認
    
    Application.DisplayAlerts = False
    Dim i As Long
    For i = 9 To 最終行 Step 3
        Range(Cells(i, 3), Cells(i + 2, 3)).Merge
        Range(Cells(i, 7), Cells(i + 2, 7)).Merge
    Next i
    Application.DisplayAlerts = True
    Range("C:C").WrapText = True
    Range("G:G").WrapText = True

End Sub

Sub 製品名挿入()
    Call 最終行確認
    Dim i As Long
    For i = 最終行 To 9 Step -1
        If Cells(i, 10) <> Cells(i - 1, 10) And Cells(i - 1, 10) <> "" Then
            Rows(8).Copy
            Rows(i).Insert Shift:=xlDown
            Application.CutCopyMode = False
            Cells(i, 2).Value = Cells(i + 1, 10).Value
        ElseIf Cells(i - 1, 10) = "" Then
            Cells(i - 1, 2).Value = Cells(i, 10).Value
        End If
    Next i
    
    Range("J:K").Delete
    Rows(最終行 & ":1000").Delete
End Sub

[新型番表シート]
Public 最終行 As Long

Sub 最終行確認()
　　最終行 = Cells(Rows.Count, 1).End(xlUp).Row
End Sub

シート名など