コメント記載の項目を抽出（表・リストから）

Excel-VBA
2023.05.05

実行内容

参考にしたサイト

マクロ全般、これからもお世話になる予定です。
数値の判定に関して
ブックのパスの取得に関して
数値が文字列として保存された場合の対処

マクロの機能

機能は大まかに３つ
１：他のエクセルブックを開き、ブック名・パスをシートに記載する
2-1：シートA列に「スタッフ対応」「割付あり」「レシピ作成」が記載されているセルを取得（コメントを取得）
2-2：②の取得したセルから、↑方向に検索し、数値が記入されているセルを取得（数値を取得）
2-3：③の取得したセルと同じ行で３列→方向の文字列を取得する（内容を取得）
３：転記した際に空白のセルを消す

全コードを載せてますが、各機能のコードを整理するため区切って載せます。
＊なお、A列にコメントと順番が記載されているものとする。

プログラム全コード

'流れとしては、転記用ファイルにてマクロを実施し、リスト・表（転記元）を開いて転記をする。
'リスト・表（転記元）はマクロ実施後に自動で閉じる

Sub Bookからsheetsの情報全てを転記_数値文字列の転記対応()
    Dim varFileName As Variant
    Dim wb1 As Workbook
    Dim wb2 As Workbook
    Dim ws1_n As String
    Dim ws1 As Worksheet
    Dim i2 As Long
    Dim i As Long
    Dim i3 As Long
    Dim sn As Long
 
    
    'マクロを実行したbookとsheetを指定できるように宣言
    Set wb1 = ThisWorkbook
    ws1_n = ActiveSheet.Name
    
    '開いているBookのパスを取得し、そこから開くようにする
    With CreateObject("WScript.Shell")
    .CurrentDirectory = ThisWorkbook.Path '最初のフォルダを設定
    End With
    
    'csv or xlsの拡張子のみ選択して開けるようにしている。
    varFileName = Application.GetOpenFilename(FileFilter:= _
                        "Microsoft Excel ブック,*.xls*,CSVファイル,*.csv", _
                        MultiSelect:=False)
    If varFileName = False Then
        Exit Sub
    End If
    
    Workbooks.Open Filename:=varFileName
    '開いたbookがactive状態なので、開いたbookが指定できるようにしている
    Set wb2 = ActiveWorkbook
    wb1.Worksheets(ws1_n).Cells(5, 1) = wb2.Name
    wb1.Worksheets(ws1_n).Cells(6, 1) = wb2.Path
       
    '追加
    Dim Rng As Range
    '入力されているcellまで実施する設定
    For sn = 1 To wb2.Worksheets.Count
        ' 数値が文字列として保存されている場合の対処、 ' の削除 + セルに1を掛けて数値にする処理(A列のみ）
        For Each Rng In wb2.Worksheets(sn).Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
            If Rng.Errors.Item(xlNumberAsText).Value = True Then
                Rng.Value = Replace(Rng.Value, "'", "", , , vbBinaryCompare)
                Rng.Value = Rng.Value * 1
            End If
        Next
        
        For i = 2 To wb2.Worksheets(sn).Cells(Rows.Count, 1).End(xlUp).Row
            ' セルに数値が入った最終行を足すことで、数値がかぶらないようにしている
            i2 = i + 7 + wb1.Worksheets(ws1_n).Cells(Rows.Count, 1).End(xlUp).Row
            '指定ワード スタッフ対応 で実行
            If wb2.Worksheets(sn).Cells(i, 1) = "スタッフ対応" _
            Or wb2.Worksheets(sn).Cells(i, 1) = "レシピ作成有" _
            Or wb2.Worksheets(sn).Cells(i, 1) = "割り付けあり" Then
            '指定ワードのcellの行を取得
            i3 = i
            '指定ワードを転記
            wb1.Worksheets(ws1_n).Cells(i2, 1) = wb2.Worksheets(sn).Cells(i, 1)
                '指定ワードの行数から↑方向に検索し、cellが数字ならfor文を終了して、その横の情報を抜き取る
                For i3 = i To 2 Step -1
                ' IsNumberを使うと空白を0として扱うので、処理が終了するのでIsNumber
                    If WorksheetFunction.IsNumber(Worksheets(sn).Cells(i3, 1)) = True Then
                        wb1.Worksheets(ws1_n).Cells(i2, 2) = wb2.Worksheets(sn).Cells(i3, 1)
                        wb1.Worksheets(ws1_n).Cells(i2, 3) = wb2.Worksheets(sn).Cells(i3, 4)
                        Exit For
                    End If
                Next
            End If
        Next
   
    Next
    For i = wb1.Worksheets(ws1_n).Cells(Rows.Count, 1).End(xlUp).Row To 9 Step -1
        If wb1.Worksheets(ws1_n).Cells(i, 1) = "" Then
            wb1.Worksheets(ws1_n).Rows(i).Delete
        End If
    Next
    '読み込んだbookを保存せずに閉じる
    wb2.Close SaveChanges:=False

End Sub

①：エクセルブックを開き、ブック名・パスを転記用シートに記載

'流れとしては、リスト・表（転記元）と転記用ファイルは同じフォルダに格納
'転記用ファイルにてマクロを実施し、リスト・表（転記元）を開いて転記をする。
'リスト・表（転記元）はマクロ実施後に自動で閉じる

Sub Bookからsheetsの情報全てを転記()
    Dim varFileName As Variant
    Dim wb1 As Workbook
    Dim wb2 As Workbook
    Dim ws1_n As String
    Dim ws1 As Worksheet
    Dim i2 As Long
    Dim i As Long
    Dim i3 As Long
    Dim sn As Long
    
    'マクロを実行したbookとsheetを指定できるように宣言
    Set wb1 = ThisWorkbook
    ws1_n = ActiveSheet.Name
    
    '開いているBookのパスを取得し、そこから開くようにする
    With CreateObject("WScript.Shell")
    .CurrentDirectory = ThisWorkbook.Path '最初のフォルダを設定
    End With
    
    'csv or xlsの拡張子のみ選択して開けるようにしている。
    varFileName = Application.GetOpenFilename(FileFilter:= _
                        "Microsoft Excel ブック,*.xls*,CSVファイル,*.csv", _
                        MultiSelect:=False)
    If varFileName = False Then
        Exit Sub
    End If
    
    Workbooks.Open Filename:=varFileName
    '開いたbookがactive状態なので、開いたbookが指定できるようにしている
    Set wb2 = ActiveWorkbook
    wb1.Worksheets(ws1_n).Cells(5, 1) = wb2.Name
    wb1.Worksheets(ws1_n).Cells(6, 1) = wb2.Path

②：転記用のコード部分

    'リスト・表にあるシート全てに実行する sn
    For sn = 1 To wb2.Worksheets.Count
      
   ' 数値が文字列として保存されている場合の対処、 ' の削除 + セルに1を掛けて数値にする処理A列のみ処理
        For Each Rng In wb2.Worksheets(sn).Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
            If Rng.Errors.Item(xlNumberAsText).Value = True Then
                Rng.Value = Replace(Rng.Value, "'", "", , , vbBinaryCompare)
                Rng.Value = Rng.Value * 1
            End If
        Next

　　　　 ' セル2～入力してある最後のセルまで実行する i
        For i = 2 To wb2.Worksheets(sn).Cells(Rows.Count, 1).End(xlUp).Row
            ' セルに数値を足すことで、ファイルとパスの転記がかぶらないように
            i2 = i + 7 + wb1.Worksheets(ws1_n).Cells(Rows.Count, 1).End(xlUp).Row
            '指定ワードでスタッフ対応 で実行
            If wb2.Worksheets(sn).Cells(i, 1) = "スタッフ対応" _
            Or wb2.Worksheets(sn).Cells(i, 1) = "レシピ作成有" _
            Or wb2.Worksheets(sn).Cells(i, 1) = "割り付けあり" Then
            '指定ワードのcellの行を取得
            i3 = i
            '指定ワードを転記用ファイル（マクロ実行ファイルに転記）
            wb1.Worksheets(ws1_n).Cells(i2, 1) = wb2.Worksheets(sn).Cells(i, 1)
                '指定ワードから↑方向に検索し、cellが数字なら横の情報を抜き取って終了
                For i3 = i To 2 Step -1
                'IsNumberを使って数値セルを取得（Numericだと空白を0と認識するで注意）
                'ワード抜き取り(i2)セルと同じ行・隣の列に並べる
                    If WorksheetFunction.IsNumber(Worksheets(sn).Cells(i3, 1)) = True Then
                        wb1.Worksheets(ws1_n).Cells(i2, 2) = wb2.Worksheets(sn).Cells(i3, 1)
                        '数値の3列となりにある作業内容を抜き取る
                        wb1.Worksheets(ws1_n).Cells(i2, 3) = wb2.Worksheets(sn).Cells(i3, 4)
                        Exit For
                    End If
                Next
            End If
        Next
　　　　Next

③転記した際の空白セルをなくす


    For i = wb1.Worksheets(ws1_n).Cells(Rows.Count, 1).End(xlUp).Row To 9 Step -1
        If wb1.Worksheets(ws1_n).Cells(i, 1) = "" Then
            wb1.Worksheets(ws1_n).Rows(i).Delete
        End If
    Next
    '読み込んだbookを保存せずに閉じる
    wb2.Close SaveChanges:=False

End Sub

コメント

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