見出し画像

*自分用 進捗メモ_3　Excelマクロ

Kumiko Kimura

＜手順A-1コード＞

Sub ModifyAndOverwrite()
    Dim ws As Worksheet
    Dim newWs As Worksheet
    Dim leftCell As Range
    Dim lastRow As Long
    
    ' シートの選択
    Set ws = ThisWorkbook.Sheets("実績表")
    ws.Copy After:=Sheets(Sheets.Count)
    Set newWs = ActiveSheet
    
    ' 1行目の削除
    ws.Rows("1").Delete
        
    ' 1行目にフィルタ設定
    ws.Rows(1).AutoFilter
    
    ' C列の追加
    ws.Columns("C:C").Insert Shift:=xlToRight
    
    ' 列名入力とセル書式の設定
    ws.Cells(1, 3).Value = "突合用の店舗コード"
    ws.Cells(2, 3).NumberFormat = "General"
    
   ' 突合用の店舗コードの入力とオートフィル
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    ws.Cells(2, 3).Formula = "=IF(ISNUMBER(SEARCH("" "", B2)), B2, MID(B2, 1, 5))"
    ws.Cells(2, 3).AutoFill Destination:=ws.Range(ws.Cells(2, 3), ws.Cells(lastRow, 3))
       

    ' ファイルの上書き保存
    Application.DisplayAlerts = False ' 上書き保存の確認ダイアログを表示しない
    ws.Parent.Save
    Application.DisplayAlerts = True  ' 設定を元に戻す
    
    ' エクセルを閉じる
    Application.Quit
End Sub

＜手順A-2コード＞

Sub ModifyAndOverwrite()
    Dim ws As Worksheet
    Dim newWs As Worksheet
    Dim lastRow As Long
    
    ' シートの選択
    Set ws = ThisWorkbook.Sheets("店舗別集計")
    ws.Copy After:=Sheets(Sheets.Count)
    Set newWs = ActiveSheet
    
    ' 1行目と2行目の削除
    ws.Rows("1:2").Delete
        
    ' 1行目にフィルタ設定
    ws.Rows(1).AutoFilter
    
    ' C列の追加
    ws.Columns("C:C").Insert Shift:=xlToRight
    
    ' 列名入力とセル書式の設定
    ws.Cells(1, 3).Value = "突合用の店舗コード"
    ws.Cells(2, 3).NumberFormat = "General"
    
    ' 突合用の店舗コードの入力とオートフィル
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    ws.Cells(2, 3).Formula = "=MID(B2,5,5)"
    ws.Cells(2, 3).AutoFill Destination:=ws.Range(ws.Cells(2, 3), ws.Cells(lastRow, 3))
    
    ' ファイルの上書き保存
    Application.DisplayAlerts = False ' 上書き保存の確認ダイアログを表示しない
    ws.Parent.Save
    Application.DisplayAlerts = True  ' 設定を元に戻す
    
    ' エクセルを閉じる
    Application.Quit
End Sub

＜手順Aを汎用化＞


・指示シートを作成して行列追加や入力内容を可変出来るようにして、コードをいじらず誰でも使えるようにする

Function ColumnLetterToNumber(ByVal colLetter As String) As Long
    Dim i As Long, result As Long
    result = 0
    For i = 1 To Len(colLetter)
        result = result * 26 + (Asc(UCase(Mid(colLetter, i, 1))) - Asc("A") + 1)
    Next i
    ColumnLetterToNumber = result
End Function


Sub InsertColumnsAndFillData()
    Dim instructionSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim numRowsToDelete As Long
    Dim numColumnsToInsert As Long
    Dim insertPosition As Long
    Dim i As Long
    Dim startCellAddress As String
    Dim endCellAddress As String
    
    
    ' 指示シートを指定
    Set instructionSheet = ThisWorkbook.Sheets("可変箇所")
    
    ' ターゲットシートを指定
    Set targetSheet = ThisWorkbook.Sheets("実績を貼る")
    
    ' 指示シートのC4セルに入力された行数を取得
    numRowsToDelete = instructionSheet.Cells(4, 3).Value
    
    ' 指定された行数だけ行を削除
    If numRowsToDelete > 0 Then
        targetSheet.Rows("1:" & numRowsToDelete).Delete
    Else
        MsgBox "削除する行数が無効です。"
        Exit Sub ' マクロを終了
    End If
      
    ' 指示シートのC12セルに入力された列数を取得
    numColumnsToInsert = instructionSheet.Cells(12, 3).Value
    
    ' 指示シートのC11セルに入力された追加位置列（アルファベット）を取得
    insertPosition = ColumnLetterToNumber(instructionSheet.Cells(11, 3).Value)
    
    ' 指定された列数分、指定された列の次に列を追加
    If numColumnsToInsert > 0 And insertPosition > 0 Then
        For i = 1 To numColumnsToInsert
            targetSheet.Columns(insertPosition).Insert Shift:=xlToRight
        Next i
    Else
        MsgBox "列数または追加位置が無効です。"
        Exit Sub ' マクロを終了
    End If
    
    ' 追加した列の一番上のセルにC15セルの内容を入力
    targetSheet.Cells(1, insertPosition).Value = instructionSheet.Cells(15, 3).Value
    
    ' C17に入力したセル番地にC18に入力された関数を入力
    Dim cellAddress As String
    Dim formula As String
    
    cellAddress = instructionSheet.Cells(17, 3).Value ' C17に入力されたセル番地を取得
    formula = instructionSheet.Cells(18, 3).formula ' C18に入力された関数を取得
    
    ' C18に入力された関数をC17で指定されたセルに入力
    targetSheet.Range(cellAddress).formula = formula
    
    ' 開始セル番地を取得　C17
    startCellAddress = instructionSheet.Cells(17, 3).Value
    
    ' 終了セル番地を取得　C19
    endCellAddress = instructionSheet.Cells(19, 3).Value
    
    ' 開始セルから終了セルまでオートフィル
    targetSheet.Range(startCellAddress & ":" & endCellAddress).formula = formula
    
    
    ' 完了メッセージ
    MsgBox "データ修正が完了しました。実績を貼るシートを確認してください。"
End Sub

＜手順Cコード＞

Sub FilterCopySumDeleteAndFormatSaveToDesktop()
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim lastRow As Long
    Dim filterValues As Variant
    Dim filterValue As Variant
    Dim copyRange As Range
    Dim sumRange As Range
    Dim lastColumn As Long
    Dim col As Long
    Dim row As Long
    Dim desktopPath As String
    
    ' フィルタをかけるシートを指定
    Set sourceSheet = Worksheets("計算")
    
    ' フィルタの値のリストを指定
    filterValues = Array("A社", "B社", "C社", "D社", "E社", "F社", "G社", "H社")
    
    ' デスクトップのパスを取得
    desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    
    ' 各フィルタ条件に対して処理を繰り返す
    For Each filterValue In filterValues
        ' フィルタをかける
        sourceSheet.Range("B2").AutoFilter Field:=2, Criteria1:=filterValue
        
        ' フィルタされたデータの最終行を取得
        lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).row
        
        ' フィルタされたデータの最終列を取得
        lastColumn = sourceSheet.Cells(2, sourceSheet.Columns.Count).End(xlToLeft).Column
        
        ' コピーする範囲を設定
        Set copyRange = sourceSheet.Range("A1:H" & lastRow)
        
        ' 新しいシートを作成してデータを転記
        Set targetSheet = Worksheets.Add(After:=Sheets(Sheets.Count))
        targetSheet.Name = filterValue & " " & company & " 案件名"
        copyRange.Copy targetSheet.Cells(1, 1)
        
        ' 合計関数を入れる
        For col = 5 To lastColumn ' E列からH列まで
            Set sumRange = targetSheet.Cells(lastRow + 3, col)
            sumRange.Formula = "=SUM(" & targetSheet.Cells(3, col).Address & ":" & targetSheet.Cells(lastRow + 1, col).Address & ")"
            sumRange.Font.Bold = True
            
            ' 合計セルに罫線を設定
            sumRange.Borders.LineStyle = xlContinuous
        Next col
        
        ' 空白セルがある場合に行を削除する
        For row = lastRow + 2 To 2 Step -1
            If WorksheetFunction.CountBlank(targetSheet.Range(targetSheet.Cells(row, 5), targetSheet.Cells(row, lastColumn))) = lastColumn - 4 Then
                targetSheet.Rows(row).Delete
            End If
        Next row
        
        ' D列の一番下の空白セルに合計と入力
        lastRowD = targetSheet.Cells(targetSheet.Rows.Count, 4).End(xlUp).row
        targetSheet.Cells(lastRowD + 1, 4).Value = "合計"
        
        ' 合計セルに罫線を設定
        targetSheet.Cells(lastRowD + 1, 4).Borders.LineStyle = xlContinuous
        
        ' D列の一番下の空白セルに合計と入力
        ' targetSheet.Cells(targetSheet.Rows.Count, 4).End(xlUp).Offset(1, 0).Value = "合計"
        
        ' 合計セルの下に空白セルがある場合に行を削除する
        If WorksheetFunction.CountBlank(targetSheet.Range(targetSheet.Cells(lastRow + 3, 5), targetSheet.Cells(lastRow + 3, lastColumn))) = lastColumn - 4 Then
            targetSheet.Rows(lastRow + 3).Delete
        End If
        

        ' A2セルからH2セルまでのセルに水色の背景色を設定
        targetSheet.Range("A2:H2").Interior.Color = RGB(221, 235, 247)
        
        ' 新しいデータをデスクトップに保存
        targetSheet.Copy
        With ActiveWorkbook
            .SaveAs desktopPath & "\同封 " & filterValue & " 案件名.xlsx"
            .Close SaveChanges:=False
        End With
    Next filterValue
        
    ' 最後にすべてのフィルタ選択を解除する
    sourceSheet.ShowAllData
    
    ' メッセージを表示
    MsgBox "同封資料作成＆デスクトップに保存しました。"
End Sub

＜手順Cのコードを一部追加、列幅を自動調整＞

Sub FilterCopySumDeleteAndFormatSaveToDesktop()
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim lastRow As Long
    Dim filterValues As Variant
    Dim filterValue As Variant
    Dim copyRange As Range
    Dim sumRange As Range
    Dim lastColumn As Long
    Dim col As Long
    Dim row As Long
    Dim desktopPath As String
    
    ' フィルタをかけるシートを指定
    Set sourceSheet = Worksheets("計算")
    
    ' フィルタの値のリストを指定
    filterValues = Array("A社", "B社", "C社", "D社", "E社", "F社", "G社", "H社")
    
    ' デスクトップのパスを取得
    desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    
    ' 各フィルタ条件に対して処理を繰り返す
    For Each filterValue In filterValues
        ' フィルタをかける
        sourceSheet.Range("B2").AutoFilter Field:=2, Criteria1:=filterValue
        
        ' フィルタされたデータの最終行を取得
        lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).row
        
        ' フィルタされたデータの最終列を取得
        lastColumn = sourceSheet.Cells(2, sourceSheet.Columns.Count).End(xlToLeft).Column
        
        ' コピーする範囲を設定
        Set copyRange = sourceSheet.Range("A1:F" & lastRow)
        
        ' 新しいシートを作成してデータを転記
        Set targetSheet = Worksheets.Add(After:=Sheets(Sheets.Count))
        targetSheet.Name = filterValue & " " & company & " 案件名"
        copyRange.Copy targetSheet.Cells(1, 1)
        
        ' 合計関数を入れる
        For col = 5 To lastColumn ' E列からF列まで
            Set sumRange = targetSheet.Cells(lastRow - 3, col)
            sumRange.Formula = "=SUM(" & targetSheet.Cells(3, col).Address & ":" & targetSheet.Cells(lastRow - 4, col).Address & ")"
            sumRange.Font.Bold = True
            
 
        ' 列幅を自動調整（合計列と請求金額列）
        targetSheet.Range(targetSheet.Cells(1, 5), targetSheet.Cells(lastRow + 1, 8)).EntireColumn.AutoFit
            
            ' 合計セルに罫線を設定
            sumRange.Borders.LineStyle = xlContinuous
        Next col
        
        ' 空白セルがある場合に行を削除する
        For row = lastRow + 2 To 2 Step -1
            If WorksheetFunction.CountBlank(targetSheet.Range(targetSheet.Cells(row, 5), targetSheet.Cells(row, lastColumn))) = lastColumn - 4 Then
                targetSheet.Rows(row).Delete
            End If
        Next row
        
        ' D列の一番下の空白セルに合計と入力
        lastRowD = targetSheet.Cells(targetSheet.Rows.Count, 4).End(xlUp).row
        targetSheet.Cells(lastRowD + 1, 4).Value = "合計"
        
        ' 合計セルに罫線を設定
        targetSheet.Cells(lastRowD + 1, 4).Borders.LineStyle = xlContinuous
               
        
        ' 合計セルの下に空白セルがある場合に行を削除する
        If WorksheetFunction.CountBlank(targetSheet.Range(targetSheet.Cells(lastRow + 3, 5), targetSheet.Cells(lastRow + 3, lastColumn))) = lastColumn - 4 Then
            targetSheet.Rows(lastRow + 3).Delete
        End If
        
        
        ' A2セルからF2セルまでのセルに水色の背景色を設定
        targetSheet.Range("A2:F2").Interior.Color = RGB(221, 235, 247)
        
        ' 新しいデータをデスクトップに保存
        targetSheet.Copy
        With ActiveWorkbook
            .SaveAs desktopPath & "\同封 " & filterValue & " 案件名.xlsx"
            .Close SaveChanges:=False
        End With
    Next filterValue
        
    ' 最後にすべてのフィルタ選択を解除する
    sourceSheet.ShowAllData
    
    ' メッセージを表示
    MsgBox "同封資料作成してデスクトップに保存しました！"
End Sub

理想や欲を言えば（もう少し時間をかけられれば）

手順Cには
・A1 案件タイトル設定→案件名を簡易名で突合結果出力の場合があるため統一性がないので手作業でやる方が現実的
・罫線→マクロ化できる、現状はSUM関数セルと合計セル以外に、マクロを動かす前の段階のデータに先に罫線をつけている
・合計と請求金額をSubtotal→マクロ化できる
・倍率計算、数字を入れるだけで自動計算するようにしたい→マクロ化できると思っている
・フィルタにかける社名を＝UNIQUE（'対象範囲'）リスト化してコードに反映させたい（現バージョン未対応）→最悪ピボットでやってもいいけどなんか嫌だ、「高度なフィルター」が使えそうかな？試してみようかな

高度なフィルター

別の場所に結果をコピーしてそのセルを参照するマクロにすればいいかな

今日はここまで

この記事が気に入ったらサポートをしてみませんか？