none
複数の別ブックから所定のセルの情報を集約する方法について RRS feed

  • 質問

  • 皆様、初歩的な質問をしてしまい、大変申し訳ございません。

    VBA初心者のものです。

    100時間以上VBAについて調べてみたのですが、

    どうしても上手くいかず、質問させていただきました。

    状況としては、

    毎日の売上のデータをブックごとに管理しているのですが、

    その各ブックのデータの1年間のトータルの情報を1つのシートに集約したいと考えております。

    集約する予定のシートは、(ファイル名:集約、集約するシート名:集約シート)です。

    売上日報のファイル名は基本「2015.〇〇」"C:\Users\2222\Desktop\売上日報\2015.11"

    となっております。

    「2015.11」のファイルの中に、「2015.11.1」「2015.11.2」~「2015.11.30」という形でブックが収納されています。

    行いたいこととしましては、

    各ブックにsheet1(売上日報のデータが記載されているシート名)の「M10 : N37」のセルのデータを

    C:\Users\2222\Desktopにあるファイル名:book1の

    シート名:集約シートに日ごとに並べたいと考えております。

    最終的にはこれを1年間分の情報を並べて、比較したいと考えているのですが、

    どうしてもVBAがうまく作れません。

    そもそも

    私が作ったコードも載せずに質問をすることが虫が良すぎるのは重々承知しております。

    もしお力添えをいただけるのであれば

    大変恐縮なのですが、ご教授していただけますと幸いです。

    ※日付は集約するシートに記載がなくても構いません。

    順番通りの場合は、自分で数えるようにいたします。

    大変お手数をおかけいたしますが、

    よろしくお願い申し上げます。

    2017年10月19日 8:13

回答

  • こんな?

    Const TARGETYEAR As Integer = 2015
    Const FOLDER As String = "D:\Users\ゆーざー\Desktop\売上日報\"
    Const RANGENAME As String = "M10:N37"
    
    Function GetFilePath(ByVal y As Integer, ByVal m As Integer) As String
        GetFilePath = FOLDER & y & "." & m & ".xlsx"
    End Function
    
    Sub CreateTestData()
        Dim dt As Date
        Dim m As Integer
        Dim d As Integer
        Dim wbMonth As Workbook
        Dim sh As Worksheet
        Dim rng As Range
        
        dt = DateSerial(TARGETYEAR, 1, 1)
        Do While Year(dt) = TARGETYEAR
            y = Year(dt)
            d = Day(dt)
            m = Month(dt)
            
            If (Day(dt) = 1) Then
                Set wbMonth = Application.Workbooks.Add
                Call wbMonth.SaveAs(GetFilePath(y, m))
                Set sh = wbMonth.Worksheets(1)
            Else
                Set sh = wbMonth.Worksheets.Add
            End If
        
            sh.Name = y & "." & m & "." & d
            For Each rng In sh.Range(RANGENAME)
                rng.Value = m & "_" & d & "_" & rng.Address
            Next
    
            dt = DateAdd("d", 1, dt)
            If (Day(dt) = 1) Then
                wbMonth.Save
                wbMonth.Close
            End If
        Loop
    End Sub
    
    Public Sub CopyToAggregate()
        Dim dt As Date
        Dim m As Integer
        Dim d As Integer
        Dim wbMonth As Workbook
        Dim shDay As Worksheet
        
        Dim shs(1 To 31) As Worksheet
        
        Dim wbTarget As Workbook
        Dim shTarget As Worksheet
        Dim rngA As Range
        Dim rng As Range
        Dim rngSource As Range
        
        Set wbTarget = Application.Workbooks.Add
        Set shTarget = wbTarget.Worksheets(1)
        shTarget.Name = "集計シート"
        
        Dim rngHeader
        Set rngHeader = shTarget.Range("B1")
        For Each rngSource In shTarget.Range(RANGENAME)
            rngHeader.Value = rngSource.Address
            Set rngHeader = rngHeader.Offset(0, 1)
        Next
        
        Set rngA = Range("A1")
    
        dt = DateSerial(TARGETYEAR, 1, 1)
        Do While Year(dt) = TARGETYEAR
            y = Year(dt)
            d = Day(dt)
            m = Month(dt)
            
            If (Day(dt) = 1) Then
                Set wbMonth = Application.Workbooks.Open(GetFilePath(y, m))
            End If
            
            Set rngA = rngA.Offset(1, 0)
            rngA.Value = dt
            
            Set rng = rngA.Offset(0, 1)
            
            Set shDay = Nothing
            On Error Resume Next
            Set shDay = wbMonth.Worksheets(y & "." & m & "." & d)
            On Error GoTo 0
            If Not (shDay Is Nothing) Then
                For Each rngSource In shDay.Range(RANGENAME)
                    rng.Value = rngSource.Value
                    Set rng = rng.Offset(0, 1)
                Next
            End If
            
            dt = DateAdd("d", 1, dt)
            If (Day(dt) = 1) Then
                wbMonth.Close
            End If
        Loop
    End Sub


    個別に明示されていない限りgekkaがフォーラムに投稿したコードにはフォーラム使用条件に基づき「MICROSOFT LIMITED PUBLIC LICENSE」が適用されます。(かなり自由に使ってOK!)

    2017年10月19日 23:38