tkhrsskの日記

技術ネタなど

複数ブックを集約して加工

EXCELと格闘する日々に効率化を。。

職場に役立ちそうな EXCEL VBA を深夜自宅で勉強中。。。眠い。

なんだか20年くらい前の仕事をしている気分。

Visual Basic for Applications - Wikipedia

f:id:tkhrssk:20150813034953p:plain

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