請問如何連接另一個檔案擷取資料和排序

amu1129

我有一些資料如下圖A

下載 (65.23 KB)

2010-8-25 00:02

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

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

下載 (21.03 KB)

2010-8-25 00:03

  

下載 (25.13 KB)

2010-8-25 00:03

GBKEE

回復 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

不好意思~版主
沒有反應耶
是還需要更改什麼嗎

Hsieh

回復 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

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

下載 (105.63 KB)

2010-9-2 22:03

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

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

麻煩請幫我修改一下~謝謝

Andy2483

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

執行前:

下載 (164.58 KB)

2023-6-19 14:18

執行結果:

下載 (211.84 KB)

2023-6-19 14:19

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