お知らせ

20210820_02

Option Explicit

Public Sub GetData()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
c = 0
'セル番地を格納（診断書136セル
data = Array("B4", "C7", "Z7", "AV7", "C8", "H8", "T8", "AV8", "Z9", "AV9", "Z10", "AV10", "C11", "H11", "T11", "Z11", "AV11", "R12", "Z12", "AV12", "N14", "K15", "AE17", "AH17", "K19", "K20", "AE20", "AH20", "AE23", "AH23", "AE26", "AH26", "AE29", "AH29", "AE32", "AH32", "AE36", "AH36", "E38", "L38", "O38", "V38", "AE38", "AH38", "E39", "L39", "O39", "V39", "E40", "L40", "O40", "V40", "E41", "L41", "O41", "V41", "AE41", "AH41", "E42", "L42", "O42", "V42", "E43", "L43", "O43", "V43", "E44", "L44", "O44", "V44", "E45", "L45", "O45", "V45", "Y45", "E46", "L46", "O46", "V46", "E47", "L47", "O47", "V47", "AB47", "AF47", "AK47", "AO47", "E48", "L48", "O48", "V48", "AB48", "AF48", "AK48", "AO48", "E49", "L49", "O49", "V49", "AB49", "AF49", "AK49", "AO49", "E50", "L50", "O50", "V50", "AB50", "AF50", "AK50", "AO50", "E51", "L51", "O51", "V51", "AB51", "AF51", "AK51", "AO51", "O52", "V52", "AB52", "AF52", "AK52", "AO52", "O53", "V53", "AB53", "AF53", "AK53", "AO53", "O54", "V54", "Z54", "AE54", "N61")

'処理対象ファイルをtemplateファイルに変更
Set WO = ThisWorkbook


'imputフォルダ（質問シート）
strfolderPath = WO.Worksheets(1).Range("E6")
strtmpfolderPath = WO.Worksheets(1).Range("E9")

'Outputフォルダパス
stroutfolderPath = WO.Worksheets(1).Range("E12")
result = ""

result = Dir(strfolderPath, vbDirectory)

'Inputファイル格納フォルダが存在するか確認
If result = "" Or result = "." Then
    MsgBox "Inputファイル格納フォルダが存在していません"
    Exit Sub
Else
End If

result = Dir(strtmpfolderPath, vbDirectory)

'Inputファイル格納フォルダが存在するか確認
If result = "" Or result = "." Then
    MsgBox "Inputファイル格納フォルダが存在していません"
    Exit Sub
Else
End If


result = Dir(stroutfolderPath, vbDirectory)

'Outputファイル格納フォルダが存在するか確認
If result = "" Or result = "." Then
    MsgBox "Outputファイル格納フォルダが存在していません"
    Exit Sub
Else
End If

'Inputファイル格納先を確認
If Dir(strfolderPath & "\*.xls*") <> "" Then
   buf = Dir(strfolderPath & "\" & "*.xls*")
   Do While buf <> ""
       c = c + 1
       ReDim Preserve arrFile(1 To c)
       strPath = strfolderPath & "\" & buf
       arrFile(c) = strPath
       buf = Dir()

   Loop
Else
    MsgBox "エラーが発生しました。フォルダの中にInputファイルが存在していません。"
End If

'templateファイル格納先を確認
If Dir(strtmpfolderPath & "\*.xltm") <> "" Then

Else
    MsgBox "エラーが発生しました。フォルダの中にtemplateファイルが存在していません。"
End If

i = 0
'Inputファイル数分だけループ
Dim tmpWS As Worksheet
Do While i < c

'以下テンプレートファイルから作成する仕様に変更
'テンプレートファイルを開いて変数へ格納
    Dim tmpWB As Workbook
    Dim tmpFileName As String
    tmpFileName = Dir(strtmpfolderPath & "\" & temFile & "*.xltm")
    Set tmpWB = Workbooks.Open(FileName:=strtmpfolderPath & "\" & tmpFileName)


    Set WS = Workbooks.Open(FileName:=arrFile(i + 1))

    Question_SHEET = ""



    For Each tmpWS In WS.Worksheets
        If tmpWS.Name Like "*質問項目(顧客回答用）*" Or tmpWS.Name Like "*質問項目(配布)*" Then
            Question_SHEET = tmpWS.Name
            Exit For
        End If
    Next tmpWS


    '質問シートから、回答貼付けシートへコピー
    WS.Worksheets(Question_SHEET).Range("A4:H88").Copy _
    Destination:=tmpWB.Worksheets(Answer_SHEET).Range("A4")

    Company = tmpWB.Worksheets(Answer_SHEET).Range("D4").Value
    If Not Company Like "*様" Then
        Company = Company & "様"
    End If

    '診断結果(本紙)シートのセルが「#N/A」や「#VALUE!」エラーになっていないか確認
    j = 0
    flag = False
    For j = LBound(data) To UBound(data)
        If flag = True Then
            Exit For
        End If
        flag = IsError(tmpWB.Worksheets(Diagnosis_SHEET).Range(data(j)))
    Next j

    '「#N/A」や「#VALUE!」エラーがあるかないかで分岐
    If flag = True Then
        errorBookName = "エラー【納品用】" & Format(Date, "yyyymmdd") & "_企業安全管理体制診断書(" & Company & ").xlsx"
        errorBookPath = WO.Worksheets(1).Range("E12") & "\" & errorBookName
        Set errorBook = Workbooks.Add
        errorBook.SaveAs errorBookPath
        Set errorBook = Workbooks.Open(errorBookPath)
        tmpWB.Worksheets(Array(Answer_SHEET, Diagnosis_SHEET)).Copy after:=errorBook.Worksheets(1)
        errorBook.Worksheets(1).Delete
        errorBook.Close savechanges:=True
        Set errorBook = Nothing
    Else

         'エラーがなければ、 貼付けテンプレートからファイルを作成
        newBookName = "【納品用】" & Format(Date, "yyyymmdd") & "_企業安全管理体制診断書(" & Company & ").xlsm"
        newBookpath = WO.Worksheets(1).Range("E12") & "\" & newBookName

         'ファイルを保存
         tmpWB.SaveAs FileName:=newBookpath, FileFormat:=xlOpenXMLWorkbookMacroEnabled

  '保存したファイルを加工
         Set tmpWB = Nothing
         Dim WB1 As Workbook

         Set WB1 = Workbooks.Open(FileName:=newBookpath)

        '加工②診断結果(本紙)シートを複製して、すべてのセルをコピー＆値貼付け
        WB1.Worksheets(Diagnosis_SHEET).Copy after:=WB1.Worksheets(Diagnosis_SHEET)
        ActiveSheet.UsedRange.Copy
        ActiveSheet.Range("A1").PasteSpecial xlPasteValues
        Application.CutCopyMode = False

        ActiveSheet.Range("A1").Select                                  '



        '加工②グラフを図のコピーして貼り付け　※元のグラフを削除
        Dim targetWS As Worksheet     ' 貼り付け対象ワークシート
        Set targetWS = ActiveSheet

        For Each spShape In targetWS.Shapes
            With spShape
                ' グラフ・チャートオブジェクトを個別に貼り付け
                If .Name Like "グラフ*" Or .Name Like "Chart*" Or .Name Like "Group*" Then 'Like "Group*"を追加

                    x = .Left
                    y = .Top

                    ' コピー失敗時にリトライ処理START
                    Dim ErrCounter As Long
                    ErrCounter = 0
                    On Error GoTo CopyErr

                    .CopyPicture Appearance:=xlScreen, Format:=xlPicture ' 図としてコピー
'                    DoEvents
                    .Delete                                              ' 元の図を削除
                    targetWS.Activate                                    '
                    targetWS.Paste                                       ' 貼り付け

                    On Error GoTo 0

                    Selection.Left = x
                    Selection.Top = y
                End If
            End With

        Next spShape
        '

        On Error GoTo ErrH

    '【納品用】yyyymmdd_企業安全管理体制診断書(株式会社○○様).xlsxを作成。

        WB1.Worksheets("診断結果(本紙)").Delete
        WB1.Worksheets("質問項目(貼り付け用）").Delete
        WB1.Worksheets("診断結果(本紙) (2)").Name = "診断結果(本紙)"
        WB1.Worksheets("診断結果(本紙)").Range("A1").Select

        '表紙のリンク貼りなおし

‘ WB1.Worksheets(“表紙・別紙”).Range(“X2:AO4”).Select
WB1.Worksheets(“表紙・別紙”).Select
ActiveSheet.Range(“X2”).Select
Selection.NumberFormatLocal = “G/標準”
Selection.Formula = “=’診断結果(本紙)’!B4”
Selection.NumberFormatLocal = “@ “”御””””中”””
WB1.Worksheets(“表紙・別紙”).Range(“A1”).Select

        '印刷シートの図のコピーのリンク貼りなおし
        WB1.Worksheets("印刷用").Visible = True
        WB1.Worksheets("印刷用").Select
        ActiveSheet.Shapes.Range(Array("Picture 3")).Select
        Selection.Formula = "='診断結果(本紙)'!$B$2:$AS$54"
        WB1.Worksheets("印刷用").Range("A1").Select
        ActiveWindow.SelectedSheets.Visible = False
        WB1.Worksheets("診断結果(本紙)").Select

        WB1.Close savechanges:=True

‘ Set WB1 = Nothing

    End If
    WS.Close
    Set WS = Nothing
    Set tmpWB = Nothing
    Set WB1 = Nothing

    i = i + 1
Loop

MsgBox "完了しました。"

ThisWorkbook.Worksheets("操作").Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True

Exit Sub

CopyErr:
ErrCounter = ErrCounter + 1

Debug.Print ErrCounter

If ErrCounter >= 4 Then
    MsgBox "グラフ貼り付けに失敗しました。"
    Exit Sub
End If

DoEvents
Resume

ErrH:
MsgBox “処理に失敗しました。” & vbNewLine & _
Err.Number & “:” & Err.Description
Exit Sub
End Sub

‘Inputフォルダ指定
Sub getFileMod()

Dim myFile As String 'フォルダパス

With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = True Then
        myFile = .SelectedItems(1)
    Else
        Exit Sub
    End If
End With

If VarType(myFile) = vbBoolean Then
    MsgBox "キャンセルされました"
    Exit Sub
Else
    ThisWorkbook.Worksheets(1).Range("E6") = myFile
End If

End Sub

‘Inputフォルダ指定
Sub getTmpFileMod()

Dim myFile As String 'フォルダパス

With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = True Then
        myFile = .SelectedItems(1)
    Else
        Exit Sub
    End If
End With

If VarType(myFile) = vbBoolean Then
    MsgBox "キャンセルされました"
    Exit Sub
Else
    ThisWorkbook.Worksheets(1).Range("E9") = myFile
End If

End Sub

‘Outputフォルダ指定
Sub outputFileMod()

 Dim myFile As String 'フォルダパス

With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = True Then
        myFile = .SelectedItems(1)
    Else
        Exit Sub
    End If
End With

If VarType(myFile) = vbBoolean Then
    MsgBox "キャンセルされました"
    Exit Sub
Else
    ThisWorkbook.Worksheets(1).Range("E12") = myFile
End If

End Sub

コメント

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