从其它workbook导入相关数据

benjaminyaong

各位大哥，小弟真的想不出来怎么解决了，希望各位帮助。。。

主要把价格从每天每个地方的价格表导入到总价格表，我每天都收到每天的价格表（如：20110528， 20110529， 20110530....），但是老板要求有每个星期的价格总表进行分析，每天每一个打非常麻烦，希望直接导入，但是不影响格式外观。。。

附件有详细内容， 希望高手贡献一下，万分感谢。。。

zhaogang1960

Sub Macro1()
    Dim MyPath$, MyName$, arr, brr(), crr(1 To 7, 1 To 3), i&, j&, m&, n&, d As Object, ds As Object
    Set d = CreateObject("scripting.dictionary")
    Set ds = CreateObject("scripting.dictionary")
    arr = Range("a1:e" & [a65536].End(xlUp).Row)
    ReDim brr(1 To UBound(arr))
    For i = 3 To UBound(arr) Step 14
        n = n + 1
        brr(n) = crr
        m = 0
        d(arr(i + 1, 1)) = n
        For j = i + 1 To i + 7
            m = m + 1
            ds(arr(j, 1) & arr(j, 2)) = m
        Next
    Next
    MyPath = ThisWorkbook.Path & "\"
    MyName = Dir(MyPath & "*.xlsx")
    Application.ScreenUpdating = False
    Do While MyName <> ""
        With GetObject(MyPath & MyName)
            arr = .Sheets(1).Range("A1").CurrentRegion
            .Close False
        End With
        For i = 2 To UBound(arr)
            If d.Exists(arr(i, 1)) Then
                If ds.Exists(arr(i, 1) & arr(i, 2)) Then
                    For j = 3 To 5
                        brr(d(arr(i, 1)))(ds(arr(i, 1) & arr(i, 2)), j - 2) = arr(i, j)
                    Next
                End If
            End If
        Next
        MyName = Dir
    Loop
    n = 0
    For i = 3 To [a65536].End(xlUp).Row Step 14
        n = n + 1
        Cells(i + 1, 3).Resize(7, 3) = brr(n)
    Next
    Application.ScreenUpdating = True
    MsgBox "完毕"
End Sub

zhaogang1960

主文件是2003，要调用的是2007格式，所以要在2007中运行：
导入数据.rar (32.2 KB, 下载次数: 34)

2011-6-2 09:35 上传

点击文件名下载附件

benjaminyaong

太感谢，太感谢了。。。。这个可以

小弟还有一个小问题。。。请看附件。。。

1，如果我我这个格式是不固定的，例如相隔的行不等，您的代码怎么改？
2，或者我对应的日期不在第二列了，而是在第三列。。怎样改。。。？？
总意思是，能不能这些都是变量，不是固定的。。。


再次感谢。。。

[ 本帖最后由 benjaminyaong 于 2011-6-2 15:05 编辑 ]

zhaogang1960

有点难度
请注意：每个数据区以“Location”开头，“Average”结束，日期就在第三列（没有设变量）
Sub Macro1()
    Dim MyPath$, MyName$, ary(), arr, brr(), crr(), i&, j&, m&, n&, lr&
    Dim c As Range, d As Object, ds As Object, firstAddress$
    Set d = CreateObject("scripting.dictionary")
    Set ds = CreateObject("scripting.dictionary")
    arr = Range("a1:c" & [a65536].End(xlUp).Row)
    lr = UBound(arr)
    ReDim brr(1 To lr)
    With [a:a]
        Set c = .Find("Location", , , xlWhole)
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                i = c.Row
                n = n + 1
                ReDim Preserve ary(1 To n)
                ary(n) = i
                d(arr(i + 1, 1)) = n
                ReDim crr(1 To WorksheetFunction.Match("Average", c.Offset(1).Resize(lr - i), 0) - 1, 1 To 3)
                brr(n) = crr
                m = 0
                For j = i + 1 To i + UBound(crr)
                    m = m + 1
                    If Len(arr(j, 1) & arr(j, 3)) Then ds(arr(j, 1) & arr(j, 3)) = m
                Next
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
    End With
    MyPath = ThisWorkbook.Path & "\"
    MyName = Dir(MyPath & "*.xlsx")
    Application.ScreenUpdating = False
    Do While MyName <> ""
        With GetObject(MyPath & MyName)
            arr = .Sheets(1).Range("A1").CurrentRegion
            .Close False
        End With
        For i = 2 To UBound(arr)
            If d.Exists(arr(i, 1)) Then
                If ds.Exists(arr(i, 1) & arr(i, 2)) Then
                    For j = 3 To 5
                        brr(d(arr(i, 1)))(ds(arr(i, 1) & arr(i, 2)), j - 2) = arr(i, j)
                    Next
                End If
            End If
        Next
        MyName = Dir
    Loop
    For i = 1 To n
        Cells(ary(i) + 1, 4).Resize(UBound(brr(i)), 3) = brr(i)
    Next
    Application.ScreenUpdating = True
    MsgBox "finished"
End Sub

zhaogang1960

附件
test.rar (74.62 KB, 下载次数: 31)

2011-6-2 16:26 上传

点击文件名下载附件

benjaminyaong

这个完全可以使，太感谢你了。。。

LMY123

ds(arr(j, 1) & arr(j, 2)) = m