Go to Qiita Advent Calendar Top
LoginSignup
2
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

@vmfhxhdyd(ふひー)inプロトアウトスタジオ

(備忘録) 細かなExcel作業をVBAに

Posted at

※ 製作用備忘録です ※

商品部のお仕事の過半は、数字関連の業務。
実績の数字データを使って、
Excelに作成した「オリジナル形式」に合わせて調整することが毎回発生。
単純な数字の貼り付けでなく、フォーマットに合わせるまでは細かな作業が多数。

大変大変.. 　とてもとても大変..
ChatGPTの力を借りてVBAを作って、時間短縮、手間を減らそう。

【作業概要】

■ Excel内にある基本Sheet

  • まとめ
  • 本年実績
  • 昨年実績
  • その他 (ここには書かない数式が入った各Sheet)

■ Excel内で発生する作業

  1. 「本年実績」・「昨年実績」シートにデータを貼り付け
  2. 「本年実績」・「昨年実績」データにピボットを実施
  3. 「本年データ」・「昨年データ」の新しいシートを作成して、ピボットしたデータを値として、貼り付け
  4. 「本年データ」を [売上高降順] に並び替え
  5. 「昨年データ」のK列に、[昨年あったが今年ない商品] を探すための、Vlook関数を適応
  6. 「昨年データ」シートのK列の値が [#N/A] だけに絞る
  7. 「本年データ」シートのA列からF列までコピーし、「まとめ」シートのＤ101セルに値で貼り付け
  8. [#N/A] だけに絞った「昨年データ」のA列からF列までコピーし、7番で貼り付け終わった、その次に引き続き貼り付け (総計と空白の列は除く)
  9. 「まとめ」シートの商品コード(G列)が重複する列を削除 (上位の値だけ残す)
  10. Excel内の全ての計算式を [手動→自動] に回す
  11. 「まとめ」シートの売上高昨対を基準にセルに色付け
    ・昨対 110％以上　⇒　アクア色
    ・昨対 90％以下　⇒　黄色背景・白色文字
    ・値が #N/Aの場合　⇒　赤色

ー ー ー ー ー ー ー ー ー ー ー ー ー ー ー ー ー ー ー ー ー ー ー ー ー ー ー
　　　　この2～11の項目を一つのVBAコードでまとめてしまう。
ー ー ー ー ー ー ー ー ー ー ー ー ー ー ー ー ー ー ー ー ー ー ー ー ー ー ー

:asterisk: VBAコードを作成し、ボタン一つを押すと、マクロ適用する。

Excel内にボタンを作成して、マクロを適用する方法

【ボタンの作成方法】
[開発] → [挿入] → 「フォームコントロール」から一つ選択 → 配置したい場所にドラッグ＆ドロップ

【マクロの適用方法】
ボタンを右クリック → [マクロの登録] → 該当マクロを選択後[OK]クリック

:asterisk: VBAとは別途、ピボットをいつも表形式に表示するように事前設定が必要

表形式に設定しない場合、ピボットが希望通りに設定できない可能性あり。

Excel [ファイル] → [オプション] → [データ] → 「ピボットテーブルの既定のレイアウトを変更する：」から[既定のレイアウトの編集] →
「小計」欄に[小計を表示しない] → 「総計」欄に[行と列の集計を行う] → 「レポートのレイアウト」欄に[表形式で表示] →
「すべてのアイテムのラベルを繰り返す」にチェックを入れる → [OK]

■ VBAコード

※コードが長いので、スクロールにご注意※

Option Explicit

Sub 実績調整_FINAL()
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim wsSrcThis As Worksheet, wsSrcLast As Worksheet, wsSummary As Worksheet
    Dim wsPivotThis As Worksheet, wsPivotLast As Worksheet
    Dim wsValThis As Worksheet, wsValLast As Worksheet
    Dim pcThis As PivotCache, pcLast As PivotCache
    Dim ptThis As PivotTable, ptLast As PivotTable
    Dim srcRng As Range
    Dim hdrRowSrcThis As Long, hdrRowSrcLast As Long
    Dim lastRowSrc As Long, lastColSrc As Long
    Dim hdrRowValThis As Long, hdrRowValLast As Long
    Dim lastRowValThis As Long, lastColValThis As Long
    Dim lastRowValLast As Long, lastColValLast As Long
    Dim startColThis As Variant, startColLast As Variant
    Dim prodColValThis As Variant, prodColValLast As Variant
    Dim chkCol As Long, pasteRow As Long
    Dim sortCol As Variant
    Dim sortRange As Range
    Dim dataStart As Long, dataEnd As Long
    Dim copyRange As Range, copyVisible As Range
    Dim dataRegion As Range
    Dim ptNameThis As String, ptNameLast As String

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False

    ' ----- 参照シート -----
    Set wsSrcThis = wb.Worksheets("本年実績")
    Set wsSrcLast = wb.Worksheets("昨年実績")

    ' まとめシートが無ければ作成
    On Error Resume Next
    Set wsSummary = wb.Worksheets("まとめ")
    If wsSummary Is Nothing Then
        Set wsSummary = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
        wsSummary.Name = "まとめ"
    End If
    On Error GoTo ErrHandler

    ' 既存の補助シートを削除（あれば）
    If SheetExists("本年ピポット") Then wb.Worksheets("本年ピポット").Delete
    If SheetExists("昨年ピポット") Then wb.Worksheets("昨年ピポット").Delete
    If SheetExists("本年データ") Then wb.Worksheets("本年データ").Delete
    If SheetExists("昨年データ") Then wb.Worksheets("昨年データ").Delete

    ' ===== 本年ピボット作成 =====
    hdrRowSrcThis = FindHeaderRow(wsSrcThis, "部門コード")
    If hdrRowSrcThis = 0 Then
        MsgBox "本年実績でヘッダー（部門コード）が見つかりません。処理中止", vbExclamation
        GoTo CleanUp
    End If

    lastRowSrc = wsSrcThis.Cells(wsSrcThis.Rows.Count, 1).End(xlUp).Row
    lastColSrc = wsSrcThis.Cells(hdrRowSrcThis, wsSrcThis.Columns.Count).End(xlToLeft).Column
    If lastRowSrc <= hdrRowSrcThis Then
        MsgBox "本年実績にデータがありません。処理中止", vbExclamation
        GoTo CleanUp
    End If

    Set srcRng = wsSrcThis.Range(wsSrcThis.Cells(hdrRowSrcThis, 1), wsSrcThis.Cells(lastRowSrc, lastColSrc))

    Set wsPivotThis = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
    wsPivotThis.Name = "本年ピポット"

    Set pcThis = wb.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=wsSrcThis.Name & "!" & srcRng.Address(ReferenceStyle:=xlR1C1))
    ptNameThis = "ptThis_" & Format(Now, "yyyymmddhhmmss")
    Set ptThis = pcThis.CreatePivotTable(TableDestination:=wsPivotThis.Range("A3"), TableName:=ptNameThis)

    ' 必須ヘッダ確認
    If Not CheckSourceHasFields(wsSrcThis, hdrRowSrcThis, Array("部門コード", "カテゴリコード", "サブカテゴリコード", "商品コード", "商品名称", "規格", "売上数量", "売上高", "荒利益高", "売変合計高")) Then
        MsgBox "本年実績の必須ヘッダが不足しています。処理中止", vbExclamation
        GoTo CleanUp
    End If

    With ptThis
        .PivotFields("部門コード").Orientation = xlRowField
        .PivotFields("カテゴリコード").Orientation = xlRowField
        .PivotFields("サブカテゴリコード").Orientation = xlRowField
        .PivotFields("商品コード").Orientation = xlRowField
        .PivotFields("商品名称").Orientation = xlRowField
        .PivotFields("規格").Orientation = xlRowField
        .AddDataField .PivotFields("売上数量"), "合計 / 売上数量", xlSum
        .AddDataField .PivotFields("売上高"), "合計 / 売上高", xlSum
        .AddDataField .PivotFields("荒利益高"), "合計 / 荒利益高", xlSum
        .AddDataField .PivotFields("売変合計高"), "合計 / 売変合計高", xlSum
    End With

    ' ===== 昨年ピボット作成 =====
    hdrRowSrcLast = FindHeaderRow(wsSrcLast, "部門コード")
    If hdrRowSrcLast = 0 Then
        MsgBox "昨年実績でヘッダー（部門コード）が見つかりません。処理中止", vbExclamation
        GoTo CleanUp
    End If

    lastRowSrc = wsSrcLast.Cells(wsSrcLast.Rows.Count, 1).End(xlUp).Row
    lastColSrc = wsSrcLast.Cells(hdrRowSrcLast, wsSrcLast.Columns.Count).End(xlToLeft).Column
    If lastRowSrc <= hdrRowSrcLast Then
        MsgBox "昨年実績にデータがありません。処理中止", vbExclamation
        GoTo CleanUp
    End If

    Set srcRng = wsSrcLast.Range(wsSrcLast.Cells(hdrRowSrcLast, 1), wsSrcLast.Cells(lastRowSrc, lastColSrc))
    Set wsPivotLast = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
    wsPivotLast.Name = "昨年ピポット"

    Set pcLast = wb.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=wsSrcLast.Name & "!" & srcRng.Address(ReferenceStyle:=xlR1C1))
    ptNameLast = "ptLast_" & Format(Now, "yyyymmddhhmmss")
    Set ptLast = pcLast.CreatePivotTable(TableDestination:=wsPivotLast.Range("A3"), TableName:=ptNameLast)

    With ptLast
        .PivotFields("部門コード").Orientation = xlRowField
        .PivotFields("カテゴリコード").Orientation = xlRowField
        .PivotFields("サブカテゴリコード").Orientation = xlRowField
        .PivotFields("商品コード").Orientation = xlRowField
        .PivotFields("商品名称").Orientation = xlRowField
        .PivotFields("規格").Orientation = xlRowField
        .AddDataField .PivotFields("売上数量"), "合計 / 売上数量", xlSum
        .AddDataField .PivotFields("売上高"), "合計 / 売上高", xlSum
        .AddDataField .PivotFields("荒利益高"), "合計 / 荒利益高", xlSum
        .AddDataField .PivotFields("売変合計高"), "合計 / 売変合計高", xlSum
    End With

    ' ===== ピボットを値シートに展開 =====
    Set wsValThis = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
    wsValThis.Name = "本年データ"
    ptThis.TableRange2.Copy
    wsValThis.Range("A1").PasteSpecial xlPasteValues

    Set wsValLast = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
    wsValLast.Name = "昨年データ"
    ptLast.TableRange2.Copy
    wsValLast.Range("A1").PasteSpecial xlPasteValues

    Application.CutCopyMode = False
    
        ' ===== ピボットシート削除 =====
    Application.DisplayAlerts = False ' 削除確認を非表示

    On Error Resume Next
    Worksheets("本年ピポット").Delete
    Worksheets("昨年ピポット").Delete
    On Error GoTo 0

    Application.DisplayAlerts = True
    

    ' ===== 値シートのヘッダ行検出（合計 / 売上高を含む行） =====
    hdrRowValThis = FindHeaderRow(wsValThis, "合計 / 売上高")
    If hdrRowValThis = 0 Then hdrRowValThis = FindHeaderRow(wsValThis, "売上高")
    If hdrRowValThis = 0 Then
        MsgBox "本年データに合計/売上高のヘッダが見つかりません。処理中止", vbExclamation
        GoTo CleanUp
    End If

    hdrRowValLast = FindHeaderRow(wsValLast, "合計 / 売上高")
    If hdrRowValLast = 0 Then hdrRowValLast = FindHeaderRow(wsValLast, "売上高")
    If hdrRowValLast = 0 Then
        MsgBox "昨年データに合計/売上高のヘッダが見つかりません。処理中止", vbExclamation
        GoTo CleanUp
    End If

    ' ===== 本年データ 全体合計/売上高 降順ソート =====
    sortCol = Application.Match("合計 / 売上高", wsValThis.Rows(hdrRowValThis), 0)
    If IsNumeric(sortCol) Then
        lastRowValThis = wsValThis.Cells(wsValThis.Rows.Count, 1).End(xlUp).Row
        lastColValThis = wsValThis.Cells(hdrRowValThis, wsValThis.Columns.Count).End(xlToLeft).Column
        Set sortRange = wsValThis.Range(wsValThis.Cells(hdrRowValThis, 1), wsValThis.Cells(lastRowValThis, lastColValThis))
        sortRange.Sort Key1:=wsValThis.Columns(sortCol), Order1:=xlDescending, Header:=xlYes
    End If

    ' ===== 昨年データ 全体合計/売上高 降順ソート =====
    sortCol = Application.Match("合計 / 売上高", wsValLast.Rows(hdrRowValLast), 0)
    If IsNumeric(sortCol) Then
        lastRowValLast = wsValLast.Cells(wsValLast.Rows.Count, 1).End(xlUp).Row
        lastColValLast = wsValLast.Cells(hdrRowValLast, wsValLast.Columns.Count).End(xlToLeft).Column
        Set sortRange = wsValLast.Range(wsValLast.Cells(hdrRowValLast, 1), wsValLast.Cells(lastRowValLast, lastColValLast))
        sortRange.Sort Key1:=wsValLast.Columns(sortCol), Order1:=xlDescending, Header:=xlYes
    End If

    ' ===== 本年データをまとめに貼る（A～F。先頭の"総計"と末尾の"(空白)"は除外） =====
    startColThis = Application.Match("部門コード", wsValThis.Rows(hdrRowValThis), 0)
    If IsError(startColThis) Then
        MsgBox "本年データで部門コード列が見つかりません。", vbExclamation
        GoTo CleanUp
    End If
    lastRowValThis = wsValThis.Cells(wsValThis.Rows.Count, startColThis).End(xlUp).Row

    dataStart = hdrRowValThis + 1
    If wsValThis.Cells(dataStart, startColThis).Value = "総計" Then dataStart = dataStart + 1
    dataEnd = lastRowValThis
    If wsValThis.Cells(dataEnd, startColThis).Value = "(空白)" Then dataEnd = dataEnd - 1

    If dataEnd >= dataStart Then
        Set copyRange = wsValThis.Range(wsValThis.Cells(dataStart, startColThis), wsValThis.Cells(dataEnd, startColThis + 5))
        copyRange.Copy
        wsSummary.Range("D101").PasteSpecial xlPasteValues
    End If

    pasteRow = wsSummary.Cells(wsSummary.Rows.Count, "D").End(xlUp).Row + 1

    ' ===== 昨年データに本年存在チェック（商品コードでVLOOKUP） =====
    prodColValThis = Application.Match("商品コード", wsValThis.Rows(hdrRowValThis), 0)
    prodColValLast = Application.Match("商品コード", wsValLast.Rows(hdrRowValLast), 0)
    If IsError(prodColValThis) Or IsError(prodColValLast) Then
        MsgBox "値シートの商品コード列が見つかりません。処理中止", vbExclamation
        GoTo CleanUp
    End If

    lastRowValLast = wsValLast.Cells(wsValLast.Rows.Count, prodColValLast).End(xlUp).Row
    lastColValLast = wsValLast.Cells(hdrRowValLast, wsValLast.Columns.Count).End(xlToLeft).Column
    chkCol = lastColValLast + 1
    wsValLast.Cells(hdrRowValLast, chkCol).Value = "本年存在チェック"
    If lastRowValLast >= hdrRowValLast + 1 Then
        wsValLast.Range(wsValLast.Cells(hdrRowValLast + 1, chkCol), wsValLast.Cells(lastRowValLast, chkCol)).FormulaR1C1 = _
            "=IFERROR(VLOOKUP(RC" & prodColValLast & ",'" & wsValThis.Name & "'!C" & prodColValThis & ",1,FALSE),""#N/A"")"
    End If

    ' ===== 昨年データで #N/A のみ抽出して A～F をまとめに貼る（先頭総計/末尾空白 除外） =====
    Set dataRegion = wsValLast.Range(wsValLast.Cells(hdrRowValLast, 1), wsValLast.Cells(lastRowValLast, chkCol))
    dataRegion.AutoFilter Field:=(chkCol - dataRegion.Columns(1).Column + 1), Criteria1:="#N/A"

    startColLast = Application.Match("部門コード", wsValLast.Rows(hdrRowValLast), 0)
    If IsError(startColLast) Then
        MsgBox "昨年データの部門コード列が見つかりません。", vbExclamation
        If wsValLast.AutoFilterMode Then wsValLast.AutoFilterMode = False
        GoTo CleanUp
    End If

    dataStart = hdrRowValLast + 1
    If wsValLast.Cells(dataStart, startColLast).Value = "総計" Then dataStart = dataStart + 1
    dataEnd = lastRowValLast
    If wsValLast.Cells(dataEnd, startColLast).Value = "(空白)" Then dataEnd = dataEnd - 1

    If dataEnd >= dataStart Then
        On Error Resume Next
        Set copyVisible = wsValLast.Range(wsValLast.Cells(dataStart, startColLast), wsValLast.Cells(dataEnd, startColLast + 5)).SpecialCells(xlCellTypeVisible)
        On Error GoTo ErrHandler
        If Not copyVisible Is Nothing Then
            copyVisible.Copy
            wsSummary.Cells(pasteRow, "D").PasteSpecial xlPasteValues
        End If
    End If

    If wsValLast.AutoFilterMode Then wsValLast.AutoFilterMode = False

    Application.CutCopyMode = False
    MsgBox "処理完了：まとめシート D101 に出力しました。", vbInformation
    
    
        '--- まとめシートの重複削除処理（商品コードG列ベース、行全体削除） ---
    Dim wsMatome As Worksheet
    Dim lastRowMatome As Long
    Dim rngCheck As Range

    Set wsMatome = ThisWorkbook.Sheets("まとめ")
    lastRowMatome = wsMatome.Cells(wsMatome.Rows.Count, "G").End(xlUp).Row

    ' D101 以降にデータがある場合のみ実行
    If lastRowMatome > 101 Then

        ' 重複削除の対象範囲を A列～AQ列に拡大
        Set rngCheck = wsMatome.Range("A101:AQ" & lastRowMatome)

        ' G列（商品コード列）を基準に重複行を削除
        ' Columns:=7 は「範囲内の7列目」＝G列を意味する
        rngCheck.RemoveDuplicates Columns:=Array(7), Header:=xlNo

    End If


    '--- 重複削除後、下の余分な行を完全削除 ---
    Dim clearStartRow As Long
    Dim lastRowAfterDel As Long

    With wsMatome
        ' 最後のデータ行（G列ベース）を取得
        lastRowAfterDel = .Cells(.Rows.Count, "G").End(xlUp).Row

        ' データの最終行より下を削除（完全削除）
        clearStartRow = lastRowAfterDel + 1
        If clearStartRow <= .Rows.Count Then
            .Rows(clearStartRow & ":" & .Rows.Count).Delete
        End If
    End With

    MsgBox "実績調整が完了しました（重複商品コード行を削除済み）", vbInformation

    
        ' ===== 計算モードを自動に戻して全再計算 =====
    Application.Calculation = xlCalculationAutomatic
    Application.CalculateFullRebuild
    
    
        ' ==== 条件付き色塗り（AC列の値に基づく） ====
    Dim wsM As Worksheet
    Dim lastRowM As Long
    Dim i As Long
    Dim valCell As Variant

    Set wsM = wb.Worksheets("まとめ")

    lastRowM = wsM.Cells(wsM.Rows.Count, "AC").End(xlUp).Row
    If lastRowM < 101 Then
        ' 対象データ無し
    Else
        For i = 101 To lastRowM
            valCell = wsM.Cells(i, "AC").Value

            ' まずリセット（C:AQ の塗りとフォント色）
            With wsM.Range("C" & i & ":AQ" & i)
                .Interior.ColorIndex = xlNone
                .Font.ColorIndex = xlAutomatic
            End With

            ' 数値かエラーかを判定
            If IsError(valCell) Then
                ' エラー（例：#DIV/0!） → 黄色
                wsM.Range("C" & i & ":AQ" & i).Interior.Color = RGB(255, 255, 0)
            ElseIf IsNumeric(valCell) Then
                ' 値はパーセントや割合で入っている前提（例：1.10 = 110%）
                If valCell >= 1.1 Then
                    ' 110%以上 → アクア色
                    wsM.Range("C" & i & ":AQ" & i).Interior.Color = RGB(0, 255, 255)
                ElseIf valCell <= 0.9 Then
                    ' 90%以下 → 赤背景・白文字
                    With wsM.Range("C" & i & ":AQ" & i)
                        .Interior.Color = RGB(255, 0, 0)
                        .Font.Color = RGB(255, 255, 255)
                    End With
                End If
            End If
        Next i
    End If



    ' ===== 処理完了メッセージ =====
    MsgBox "実績調整がすべて完了しました。" & vbCrLf & _
           "計算モードを自動に戻し、関数を再計算しました。", vbInformation, "完了"
    
    
CleanUp:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Exit Sub

ErrHandler:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    MsgBox "エラー発生: " & Err.Number & " - " & Err.Description, vbCritical
       
End Sub

' -------------------------
' ヘルパー関数
' -------------------------
Private Function FindHeaderRow(ws As Worksheet, headerName As String) As Long
    Dim r As Long, m As Variant
    For r = 1 To 10
        On Error Resume Next
        m = Application.Match(headerName, ws.Rows(r), 0)
        On Error GoTo 0
        If Not IsError(m) Then
            FindHeaderRow = r
            Exit Function
        End If
    Next r
    FindHeaderRow = 0
End Function

Private Function CheckSourceHasFields(ws As Worksheet, hdrRow As Long, requiredFields As Variant) As Boolean
    Dim f As Variant, res As Variant
    For Each f In requiredFields
        On Error Resume Next
        res = Application.Match(f, ws.Rows(hdrRow), 0)
        On Error GoTo 0
        If IsError(res) Then
            CheckSourceHasFields = False
            Exit Function
        End If
    Next f
    CheckSourceHasFields = True
End Function

Private Function SheetExists(sName As String) As Boolean
    Dim sh As Worksheet
    On Error Resume Next
    Set sh = ThisWorkbook.Worksheets(sName)
    On Error GoTo 0
    SheetExists = Not sh Is Nothing
End Function

これで30分の作業が、1分へ。

2
0
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
2
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?