Board logo

標題: 請問如何連接另一個檔案擷取資料和排序 [打印本頁]
作者: amu1129    時間: 2010-8-25 00:13     標題: 請問如何連接另一個檔案擷取資料和排序

我有一些資料如下圖A
[attach]2565[/attach]

我想如下圖B&C的表格B2輸入商品名稱
然後會自動連結到圖A的檔案
擷取尺寸、編號和數量的資料
而且前面有編號
尺寸以B01→B02→A01→A02排序
編號則遞增排序

最下面則是有數量的合計
接著以表格框起來
請問這該怎麼寫
[attach]2566[/attach]  [attach]2567[/attach]

[attach]2567[/attach]
作者: GBKEE    時間: 2010-8-25 09:45

回復 1# amu1129
  1. Sub Ex()
  2.     Dim AR, d As Object, Rng As Range, E, i%, Sh$, DKey
  3.     Set d = CreateObject("Scripting.Dictionary")
  4.     With Sheet1
  5.         AR = Split(.[B1], ",")
  6.         For i = 0 To UBound(AR)
  7.             For Each E In .Range("B4", .[B4].End(xlDown))
  8.                 If .Cells(E.Row, "F") = AR(i) Then
  9.                     d(E & E.Offset(, 1)) = Array(AR(i), E.Offset(, 1), E.Offset(, 5))
  10.                     If InStr(Sh, E) = 0 Then Sh = IIf(Sh <> "", Sh & "," & E, E)
  11.                 End If
  12.             Next
  13.         Next
  14.     End With
  15.     i = 2
  16.     For Each E In Split(Sh, ",")
  17.         On Error GoTo Er
  18.         With Sheets(i)
  19.             .Cells.Clear
  20.             .[B2] = E
  21.             .[B4].Resize(, 3) = Array("尺寸", "編號", "數量")
  22.             For Each DKey In d.keys
  23.                 If DKey Like E & "*" Then
  24.                     With .Range("b" & Rows.Count).End(xlUp).Offset(1)
  25.                         .Resize(, 3) = d(DKey)
  26.                         .Offset(, -1) = .Row - 4
  27.                     End With
  28.                 End If
  29.             Next
  30.             With .Range("b" & Rows.Count).End(xlUp)
  31.                 .Offset(1) = "合計"
  32.                 .Offset(1, 2) = Evaluate("=SUM(" & .Offset(, 2).Address(, , , 1) & ":D5)")
  33.             End With
  34.             .Range("B4").CurrentRegion.Borders.LineStyle = 1
  35.         End With
  36.         i = i + 1
  37.     Next
  38. Exit Sub
  39. Er:
  40.     If Err = 9 Then
  41.         Sheets.Add , Sheets(Sheets.Count)
  42.         Resume
  43.     Else
  44.         MsgBox Err
  45.     End If
  46. End Sub
複製代碼
作者: amu1129    時間: 2010-9-1 20:20

不好意思~版主
沒有反應耶
是還需要更改什麼嗎
作者: Hsieh    時間: 2010-9-1 22:29

回復 3# amu1129
在BOOK1跟BOOK2的Sheet1模組內輸入程式碼
改變BOOK1跟BOOK2的Sheet1的b2儲存格試試
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2. Dim Ar(), Ay(), A As Range
  3. Ky = Array("B01", "B02", "A01", "A02")
  4. If Target.Address <> "$B$2" Then Exit Sub
  5. fs = ThisWorkbook.Path & "\5 B01,B02,A01,A02.xls"
  6. ReDim Preserve Ay(k)
  7. Ay(k) = Array("", "尺寸", "編號", "數量")
  8. k = k + 1
  9. With Workbooks.Open(fs)
  10.    With .Sheets(1)
  11.      For Each A In .Range(.[B4], .[B65536].End(xlUp))
  12.         If A = Target Then
  13.            ReDim Preserve Ar(s)
  14.            Ar(s) = Array(A.Offset(, 4).Value, A.Offset(, 1).Value, A.Offset(, 5).Value)
  15.            cnt = cnt + A.Offset(, 5).Value
  16.            s = s + 1
  17.         End If
  18.     Next
  19.    End With
  20.    .Close 0
  21. End With
  22. For i = 0 To 3
  23.    For j = 0 To UBound(Ar)
  24.       If Ar(j)(0) = Ky(i) Then
  25.          ReDim Preserve Ay(k)
  26.          Ay(k) = Array(k, Ar(j)(0), Ar(j)(1), Ar(j)(2))
  27.          k = k + 1
  28.       End If
  29.    Next
  30. Next
  31. ReDim Preserve Ay(k)
  32. Ay(k) = Array("", "合計", "", cnt)
  33. k = k + 1
  34. With Me
  35.    .[A3:D65536].Clear
  36.    .[A4].Resize(k, 4).Value = Application.Transpose(Application.Transpose(Ay))
  37.    .Range("A2").Resize(k + 2, 4).Borders.LineStyle = 1
  38.    .Range("A2").Resize(k + 2, 4).Borders.Weight = xlThin
  39.    .Range("B2").Resize(k + 2, 3).BorderAround 1, xlThick, xlColorIndexAutomatic
  40. End With
  41. End Sub
複製代碼
作者: amu1129    時間: 2010-9-2 22:13

不好意思~不知道為什麼就是不會跑
如果我想改成如下圖
[attach]2672[/attach]

程式一
一開始為編號1圖
接著在儲存格B2輸入
會跑出如編號2圖

程式二
在F欄重複編號下貼上重複編號(編號3圖)
會自動將重複的編號給刪除
接著才跑出下面數量的合計
最後以框線起來

麻煩請幫我修改一下~謝謝
作者: Andy2483    時間: 2023-6-19 14:19

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教

執行前:
[attach]36621[/attach]

執行結果:
[attach]36622[/attach]


Option Explicit
Sub TEST()
Dim Brr, Crr(1 To 1000, 1 To 250), Z, B, v&, i&, R&, C%, x%, u&, T5$, T1$
[I:IV].Delete
Set Z = CreateObject("Scripting.Dictionary")
Brr = Range([Sheet1!G4], [Sheet1!B65536].End(xlUp))
For Each B In Split([B1], ",")
   i = i + 1: Z("/" & B & "/") = i
Next
For i = 1 To UBound(Brr)
   T1 = Brr(i, 1): T5 = Brr(i, 5)
   If Z("/" & T5 & "/") = "" Then GoTo i01
   B = Z(T1)
   R = Z(T1 & "/r") + 1
   If Not IsArray(B) Then
      B = Crr
      x = x + 1
      Z(T1 & "/c") = x
      Z(T1 & "/r") = 1
   End If
   B(R, 1) = Z("/" & T5 & "/")
   B(R, 2) = T5
   B(R, 3) = Brr(i, 2)
   B(R, 4) = Val(Brr(i, 6))
   Z(T1 & "/r") = R
   Z(T1) = B
i01: Next
For Each B In Z.KEYS
   If Not IsArray(Z(B)) Then GoTo v01
   u = Z(B & "/c")
   v = Z(B & "/r")
   With Cells(1, (u - 1) * 5 + 9).Resize(v + 2, 4)
      .Item(1) = "序號 \ " & B
      .Item(2) = "尺寸"
      .Item(3) = "編號"
      .Item(4) = "數量"
      .Item(2, 1).Resize(v, 4).Value = Z(B)
      .Sort KEY1:=.Item(1), Order1:=1, _
            Key2:=.Item(3), Order2:=1, Header:=1
      With .Item(2, 1).Resize(v)
         .Value = "=ROW(" & .Address(0, 0) & ")-1"
      End With
      .Item(v + 2, 2) = "合計"
      .Item(v + 2, 4) = "=SUM(" & .Item(2, 4).Resize(v).Address & ")"
      .EntireColumn.AutoFit
      .Borders.LineStyle = 1
   End With
v01: Next
Set Z = Nothing: Erase Brr, Crr
End Sub



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)