楼主
herelazy |
Q：每天的价格表（如：20110528， 20110529， 20110530....），如何导入价格汇总周表中？
A：- Sub cs()
- Dim arr(), d, i&, p$, a$, n&, dk, j&, dn&, trr, brr(), k&, ddi
- Application.ScreenUpdating = False
- Set d = CreateObject("scripting.dictionary")
- trr = Array("Location", "Date", "Price1", "Price2", "Price3")
- p = ThisWorkbook.Path
- a = Dir(p & "\*.xls")
- Do While a > ""
- If a <> ThisWorkbook.Name Then
- n = n + 1
- ReDim Preserve arr(1 To n)
- Workbooks.Open p & "\" & a
- arr(n) = ActiveWorkbook.Sheets(1).[a1].CurrentRegion
- For i = 2 To UBound(arr(n))
- If d.exists(arr(n)(i, 1)) Then
- d(arr(n)(i, 1))(arr(n)(i, 2)) = n & Chr(10) & i
- Else
- Set d(arr(n)(i, 1)) = CreateObject("scripting.dictionary")
- d(arr(n)(i, 1))(arr(n)(i, 2)) = n & Chr(10) & i
- End If
- Next
- ActiveWorkbook.Close
- End If
- a = Dir
- Loop
- dk = d.keys
- With Sheets(1)
- .Cells.Clear
- .Cells.Font.Name = "Calibri"
- .Cells.Font.Size = 11
- For i = 1 To d.Count
- dn = d(dk(i - 1)).Count
- ddi = d(dk(i - 1)).items
- j = dn + 7 + j
- ReDim Preserve brr(1 To 5, 1 To j)
- For n = 1 To dn + 1
- For k = 1 To 5
- If n = 1 Then
- brr(k, j - dn - 7 + 1) = trr(k - 1)
- Else
- brr(k, j - dn - 7 + n) = arr(Split(ddi(n - 2), Chr(10))(0) * 1)(Split(ddi(n - 2), Chr(10))(1) * 1, k)
- End If
- Next
- Next
- .Cells(j - dn - 4, 1).Resize(1, 5).Interior.ColorIndex = 43
- .Cells(j - dn - 4, 1).Resize(dn + 1, 5).Borders.LineStyle = 1
- brr(1, j - 4) = "Average"
- brr(3, j - 4) = "=round(average(C" & j - dn - 3 & ":C" & j - 4 & "),2)"
- brr(4, j - 4) = "=round(average(d" & j - dn - 3 & ":d" & j - 4 & "),2)"
- brr(5, j - 4) = "=round(average(e" & j - dn - 3 & ":e" & j - 4 & "),2)"
- brr(1, j - 3) = "Low"
- brr(3, j - 3) = "=min(C" & j - dn - 3 & ":C" & j - 4 & ")"
- brr(4, j - 3) = "=min(d" & j - dn - 3 & ":d" & j - 4 & ")"
- brr(5, j - 3) = "=min(e" & j - dn - 3 & ":e" & j - 4 & ")"
- brr(1, j - 2) = "Hight"
- brr(3, j - 2) = "=max(C" & j - dn - 3 & ":C" & j - 4 & ")"
- brr(4, j - 2) = "=max(d" & j - dn - 3 & ":d" & j - 4 & ")"
- brr(5, j - 2) = "=max(e" & j - dn - 3 & ":e" & j - 4 & ")"
- .Cells(j - 2, 1).Resize(3, 5).Interior.ColorIndex = 48
- .Cells(j - 2, 1).Resize(3, 5).Borders.LineStyle = 1
- Next
- .[a1] = "WEEEKY PRICE"
- .[a3].Resize(UBound(brr, 2), 5) = Application.Transpose(brr)
- End With
- Set d = Nothing
- Application.ScreenUpdating = True
- End Sub
P.S.必须把每日价格表和汇总表放在一个文件夹中，否则将导致“下表越界”。
 价格汇总表.rar
|
