thisworkbook(xlsm)でデータ取り込み後、xlsx保存

目的マクロ実行ブックはxlsm。データ取り込み後、コピーをxlsxで保存したい。

　IPO(入力、処理、出力）の入力と出力をVBAでやるだけで、処理は極力Excelの計算でやればメンテナンスも簡単でしょうというExcel自動化の肝をまとめた素晴らしい記事。

-----以下サイトから引用-----

”A2セルに入力してあるパスで指定した元データから値をSheet2に貼り、それを数式参照でSheet3に持ってきて、そのままSheet3だけを新しい保管用ファイルとしてA５セルに入力してある保管先に格納できたわけです。
　ということなので、このツール自体は保存せずに閉じてしまって構いませんね。
というより保存してしまったらSheet3の数式が潰れるので、次回以降使えません。
ですからうっかり保存しないよう、閉じるところまでVBAで指示してあります。”

-----以上サイトから引用-----

→これをベースに自己流に整理。コードの正確なものはリンク先サイト様で確認。Sheet1のA2セルに取込元ブックのフルパス、A4セルに保存先フォルダのフルパスが書いてあるのが以下に記述下コードの前提。

メンテを考えると、取込ファイルの指定は、コードで直接指定するならセルでフルパスを入力する方法が優れている。それか、対話(GetOpenFileName)で指定させるか。

'**********取込(インプット）１(元データExcel）************
Sub エクセルファイル取込()
    With ThisWorkbook
        'シート初期化
        .Sheets("取込１").Cells.ClearContents
        
        'thisworkbookの「TOP」シートのA２セルには、取込元ブックのフルパスが書いてある。
        '取込元ブックの「sheet1」シートを開き、すべてのセルをコピー。Thisworkbookの「取込1」シートの、A1セルを基点に貼付け
        Workbooks.Open(.Worksheets("TOP").Range("A2").Value).Worksheets("Sheet1").Cells.Copy _
            .Worksheets("取込1").Range ("A1")
    End With
End Sub




'**********取込(インプット）２（元データｃｓｖ）************
'テキストファイルウィザード(Excel2013までのレガシイ機能。外部データの取込み)
Sub CSVデータ取込()
    With ThisWorkbook
        'シート初期化
        .Sheets("取込1").Cells.ClearContents
    
        '外部データテーブルを追加してインポート
        With .Sheets("取込1").QueryTables.Add( _
            Connection:="TEXT;" & .Worksheets("TOP").Range("A2").Value, _
            Destination:=ThisWorkbook.Sheets("取込1").Range("A1"))
                'データ区切り形式を区切り文字形式に設定
                .TextFileParseType = xlDelimited
                '取込開始行を1行目からに設定
                .TextFileStartRow = 1
                 '文字列の引用符をダブルコーテーションに設定
                .TextFileTextQualifier = xlTextQualifierDoubleQuote
                '連続区切り文字を1文字扱いに設定
                .TextFileConsecutiveDelimiter = False
                'カンマ区切りオン
                .TextFileCommaDelimiter = True
                'スペース区切りオフ
                .TextFileSpaceDelimiter = False
                'セミコロン区切りオン
                .TextFileSemicolonDelimiter = False
                'タブ区切りオフ
                .TextFileTabDelimiter = False
                'その他区切りオフ
                .TextFileOtherDelimiter = ""
                '10列のデータに対して、先頭の0が消えないように、すべての列データを文字列型に設定して取り込む
                '例：1(標準)、2(文字列)、など。
                'すべて1(標準)なら設定不要なので省略可
                '20191102追記　10列あれば10列の指定が必要だと思っていた。
                'しかし、全部で10列のときに、右辺の要素数が500個あってもOK！
                'したがって、とにかく文字列型にしたいなら、余裕を持った要素数で、2(文字列)の配列用意すればOK
                .TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 2, 2, 2, 2)
                '列幅オートフィット
                .AdjustColumnWidth = True
                'バックグラウンド更新オフ
                .BackgroundQuery = False
                '上記設定で取込。’バックグラウンド更新なし
                .Refresh BackgroundQuery:=False
                'クエリ定義(リンク)削除。
                .Delete
        End With
    End With
End Sub


'**********処理(プロセス)**********
'文字列数値にフィルタかける例
Sub フィルタで000以外抽出()
    ThisWorkbook.Sheets("取込1").Range("A1").AutoFilter _
        Field:=3, _
        Criteria1:="<>000＊", _
        Operator:=xlAnd, _
        Criteria2:="<>000"
End Sub


'**********出力(アウトプット)１**********
'保存先フォルダを予めセルに記入しておくことで指定するケース
Sub 指定フォルダに保存() 
    With ThisWorkbook.Worksheets("出力1")
        '保存前に関数全削除（値貼付け）
        .Cells.Value = .Cells.Value
        
        '保存前にシート名を変更
        .Name = "出力001"
    End With

    With ThisWorkbook.Worksheets("出力2")
        '保存前に関数全削除（値貼付け）
        .Cells.Value = .Cells.Value
        
        '保存前にシート名を変更
        .Name = "出力002"
    End With
    
    '取り出すシートを指定
    With Sheets(Array("出力001", "出力002"))
        '空のブックにシートをコピー
         .Copy
    End With
    
    'コピーしたブックを保存
    'xlsxで保存するなら引数FileFormatが必要。SaveAsCopyは拡張子変更すると開けなくなってハマった。
    'そこで、xlsmをコピーしてxlsxにするには、ブックコピーしてからSaveAsを使うことにする。
    '今回のThisworkbookのShee1のtA5セルには、保存先ファイルのフルパスが書いてある。
     ActiveWorkbook.SaveAs ThisWorkbook.Worksheets("Sheet1").Range("A5").Value & myfolderName & "保管用ファイル名称.xlsx", _
                            FileFormat:=xlOpenXMLWorkbook
    
    '実行ブックは保存せずに閉じる
     ThisWorkbook.Close SaveChanges:=False

End Sub



'**********出力(アウトプット)２**********
'保存用フォルダをマクロ実行の都度作成するケース。
Sub フォルダ作成して保存()
    '保管用フォルダ作成
    '以下エラー無視する
    '既に同じ名前のフォルダがあるとエラー。そのときは作成しないのが目的。
    On Error Resume Next
        Dim myfolderName As String
        '例　マクロ実行時の時刻が2020年7月31日13時5分10秒なら、20200731_130510を格納
        myfolderName = Format(Now, "yyyymmdd_hhnnss")
        
        'Thisworkbookと同じ階層に保管用フォルダ作成
        MkDir ThisWorkbook.Path & "\" & myfolderName
    'エラー無視するのをやめる
    On Error GoTo 0
    
    
    With ThisWorkbook.Worksheets("出力1")
        '保存前に関数全削除（値貼付け）
        .Cells.Value = .Cells.Value
        
        '保存前にシート名を変更
        .Name = "出力001"
    End With

    With ThisWorkbook.Worksheets("出力2")
        '保存前に関数全削除（値貼付け）
        .Cells.Value = .Cells.Value
        
        '保存前にシート名を変更
        .Name = "出力002"
    End With
    
    '取り出すシートを指定
    With Sheets(Array("出力001", "出力002"))
        '空のブックにシートをコピー
         .Copy
    End With
    
    'コピーしたブックを保存
    'xlsxで保存するなら引数FileFormatが必要。SaveAsCopyは拡張子変更すると開けなくなってハマった。
    'そこで、xlsmをコピーしてxlsxにするには、ブックコピーしてからSaveAsを使うことにする。
     ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & myfolderName & "\保管用ファイル名称.xlsx", _
                            FileFormat:=xlOpenXMLWorkbook
    
    '実行ブックは保存せずに閉じる
     ThisWorkbook.Close SaveChanges:=False

End Sub

-------------------------

というのは、Excel2013まで。エクセル2016になれば、PowerQueryで取込（インプット）と処理（プロセス）の大部分をまとめてすることができるようになるので、その接続を呼び出すだけでかなりできるようになりそう。ただ、出力の部分はやはりVBAだろう。