おつかれさまです。

指定したシートを削除して取り込み VBA【忘備録】

忘備録。指定したシートを削除。別のEXCELから取り込み。

【案件】日々更新されてる複数シートのEXCELデータを1シートにまとめる。

そのままでもできるが、元データを見たり修正したりしたいのでデータをまとめて別EXCELに取り込みたい。
※元EXCELシートの更新は不可。

指定したシートを削除して、対象のEXCELからコピーする。
※集計は別途。

-1-

'### 別EXCEL使用時 ###
Dim writeSheet As Worksheet ' 自分自身の書き出し先シート
Dim strBookName As Workbook

'*** 行、列 処理用 ***
Dim set_data01 As Object
Dim set_data02 As Object

    MSG_FLG = MsgBox(" シートDelete & 取込み ", vbYesNo)	
    If MSG_FLG = vbNo Then	
       Exit Sub	
    End If	

    Application.DisplayAlerts = False	
'  ***クリア処理***	
   '### シートフィルタ解除サブプロシジー ###	
    sheet_clear	
	
   '### 削除確認MSG解除	
   	
    Set set_data01 = Worksheets("シート名").Range("A2")	

   
シート名シートのA列2行目から、シート名を記載しておく。   
Set set_data01 = Worksheets(“シート名").Range(“A2")
   
-2-

   '### 繰り返し処理 "シート名"シートのA列がスペースで抜ける。
    Do Until set_data01.Offset(0, 0).value = ""	
       On Error Resume Next '### エラースキップ	
          '###シートが存在してるとき削除	
          Set writeSheet = ThisWorkbook.Worksheets(set_data01.Offset(0, 0).value)	
          Worksheets(set_data01.Offset(0, 0).value).Delete	
       On Error GoTo 0	
       Set set_data01 = set_data01.Offset(1, 0)	
       CNT01 = CNT01 + 1	
    Loop	

    WritemyBook = ActiveWorkbook.Name	'### 現在のBOOK名称を保存
    mySheetName002 = "DATA集計"	
   	
'  ### クリア処理 全シートのフィルタを解除 ※誤作動防止(通常はサブプロシジャー)***	
    For CLEAR001 = 1 To Worksheets.Count
       If Sheets(Worksheets(CLEAR001).Name).AutoFilterMode Then
          Sheets(Worksheets(CLEAR001).Name).Range("A1").AutoFilter
       End If
    Next
   	
    Sheets(mySheetName002).Select	
    Cells.Select	
    Selection.Delete Shift:=xlUp	
   	
    Sheets(mySheetName002).Select	
    Range("A1").Select	

以下編集中※※※※※※※※※※※※※※※※※※
-3-

    MSG_FLG = MsgBox(" シートDelete & 取込み ", vbYesNo)	
    If MSG_FLG = vbNo Then	
       Exit Sub	
    End If	

    Application.DisplayAlerts = False	
'  ***クリア処理***	
    For CLEAR001 = 1 To Worksheets.Count
       If Sheets(Worksheets(CLEAR001).Name).AutoFilterMode Then
          Sheets(Worksheets(CLEAR001).Name).Range("A1").AutoFilter
       End If
    Next
	
    Set set_data01 = Worksheets("シート名").Range("A2")	
   	
    Do Until set_data01.Offset(0, 0).value = ""	
'       writeSheet = ""	
       	
       On Error Resume Next '### エラースキップ	
      	
          '###シートが存在してるとき削除	
          Set writeSheet = ThisWorkbook.Worksheets(set_data01.Offset(0, 0).value)	
          Worksheets(set_data01.Offset(0, 0).value).Delete	
      	
       On Error GoTo 0	
       Set set_data01 = set_data01.Offset(1, 0)	
       CNT01 = CNT01 + 1	
    Loop	
    '### 削除確認MSG解除の解除	
   	
    WritemyBook = ActiveWorkbook.Name	
    mySheetName002 = "DATA集計"	
   	
'  ***クリア処理***	
   '### シートフィルタ解除サブプロシジー ###	
    sheet_clear	
   	
    Sheets(mySheetName002).Select	
    Cells.Select	
    Selection.Delete Shift:=xlUp	
   	
    Sheets(mySheetName002).Select	
    Range("A1").Select	
	
   '############################################################	
   	
    Const cnsTITLE = "○予約 Xls取込み(*.Xlsx)処理"	
    Const cnsFILTER = "○予約 (*.Xlsx),*.Xlsx"	
	
    With CreateObject("WScript.Shell")	
        .CurrentDirectory = Worksheets("KANRI").Range("B1") '@@ シート設定	
    End With	
   	
    vFILENAME = Application.GetOpenFilename(FileFilter:=cnsFILTER, title:=cnsTITLE)	
    If VarType(vFILENAME) = vbBoolean Then	
       MsgBox ("キャンセル")	
       Exit Sub	
   End If	
   	
    Set set_data01 = Worksheets("シート名").Range("A2")	
    Set writeSheet = ThisWorkbook.Worksheets(mySheetName002) ' 元Sheet セット	
    Set strBookName = Workbooks.Open(vFILENAME) '相手オープン	
   	
    '### 登録シート名をCOPY	
    Do Until set_data01.Offset(0, 0).value = ""	
      strBookName.Worksheets(set_data01.Offset(0, 0).value).Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)	
       Set set_data01 = set_data01.Offset(1, 0)	
    Loop	
	
' 相手クローズ クリップモードメッセージ、保存メッセージ、飛ばす	
    Application.CutCopyMode = False	
    Application.DisplayAlerts = False	
    strBookName.Close savechanges:=False	
    Application.DisplayAlerts = True	
   	
    writeSheet.Activate '元選択(download)	
    Set writeSheet = Nothing	
    Set strBookName = Nothing	
   	
    Application.DisplayAlerts = True	
    Range("A1").Select	
    MsgBox ("取込み終了")	

がんばりましょう。

VBA(マクロ)

Posted by master