指定したシートを削除して取り込み 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 ("取込み終了")