EXCELと格闘する日々に効率化を。。
職場に役立ちそうな EXCEL VBA を深夜自宅で勉強中。。。眠い。
なんだか20年くらい前の仕事をしている気分。
Visual Basic for Applications - Wikipedia
Sub OpenBookSheet(ByVal FilePath As String, ByVal Sheet As String, ByVal NewSheet As String)
Const xKey_Col = 1 'キー列番号
Const xHeads = 1 '見出しの行数
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim TargetBook As Workbook
Set TargetBook = Workbooks.Open(Filename:=FilePath)
ThisWorkbook.Activate
' アクティブシートを記憶
Dim OldSheet As Worksheet
Set OldSheet = ActiveSheet
' 新シートを作成
Dim NewWorkSheet As Worksheet
ThisWorkbook.Worksheets(NewSheet).Delete
Set NewWorkSheet = Worksheets.Add()
NewWorkSheet.Name = NewSheet
With TargetBook.Sheets(Sheet)
xLast = .Cells(Rows.Count, xKey_Col).End(xlUp).Row
Application.CutCopyMode = False
.UsedRange.Copy
NewWorkSheet.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
End With
TargetBook.Close
OldSheet.Activate
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub DeleteRow(ByVal Sheet As String, ByVal StartTarget As String, ByVal EndTarget As String)
'行削除
ThisWorkbook.Worksheets(Sheet).Range(StartTarget & ":" & EndTarget).Delete
End Sub
Sub 集計開始()
' ブックと同一のパスからファイルを検索
Dim buf As String, cnt As Long
Dim Col As Long
Dim Path As String
Dim File As String
Dim Sheet As String
Dim NewSheet As String
Dim PathFile As String
Dim Target As String
Path = ThisWorkbook.Path
For cnt = 0 To 5
File = Cells(cnt + 6, 2)
Sheet = Cells(cnt + 6, 3)
NewSheet = Cells(cnt + 6, 4)
If File = "" Then Exit For
If Sheet = "" Then Exit For
If NewSheet = "" Then Exit For
' ファイル名 記録
PathFile = Path & "\\" & File
buf = Dir(PathFile)
Cells(cnt + 6, 6) = buf
' シートのコピー
OpenBookSheet Path & "\\" & buf, Sheet, NewSheet
' 範囲削除
For Col = 0 To 10 Step 2
StartTarget = Cells(cnt + 6, Col + 7)
EndTarget = Cells(cnt + 6, Col + 8)
If StartTarget <> "" And EndTarget <> "" Then
DeleteRow NewSheet, StartTarget, EndTarget
End If
Next Col
Next cnt
End Sub
