Board logo

標題: [發問] 如何讓不同檔案同一貨號自動匯入總表 [打印本頁]
作者: s7659109    時間: 2013-9-17 15:32     標題: 如何將明細表的特定值彙整到總表中

如何將明細表A001、A002、A003中貨號為001匯入總表內。
作者: GBKEE    時間: 2013-9-19 16:51

本帖最後由 GBKEE 於 2013-9-23 16:49 編輯

回復 1# s7659109
試試看
  1. Sub Ex_特定值彙整到總表()
  2.     Dim xNO As String, AR(), A, Sh As Worksheet, R As Range, i As Integer, xR As Integer
  3.     xNO = InputBox("輸入貨號")
  4.     If xNO = "" Then Exit Sub
  5.     i = 1
  6.     For Each Sh In Sheets
  7.         If InStr(Sh.Name, "A0") = 1 Then
  8.             For Each R In Sh.Range("a1").CurrentRegion.Columns("B").Cells
  9.                 If R.Text = xNO Then
  10.                 A = Sh.Range("a1").CurrentRegion.Rows(R.Row)
  11.                 ReDim Preserve AR(1 To i)
  12.                 AR(i) = A
  13.                 i = i + 1
  14.                 End If
  15.             Next
  16.         End If
  17.     Next
  18.     If i = 1 Then MsgBox "貨號: 找不到  " & xNO: Exit Sub
  19.     With Sheets("總表").Range("A1").CurrentRegion
  20.         .Parent.Activate
  21.         .Offset(2).Clear
  22.         .Range("A3").Resize(i - 1, UBound(A, 2)) = Application.Transpose(Application.Transpose(AR))
  23.          xR = Sheets("總表").Range("A1").CurrentRegion.Rows.Count
  24.         .Cells(3, 2).Resize(xR - 2).NumberFormatLocal = "@"
  25.         .Cells(3, 2).Resize(xR - 2).FormulaR1C1 = xNO
  26.         .Cells(xR + 1, 1) = "合計"
  27.         .Cells(xR + 1, 5) = "=SUM(R[-1]C:R[-" & xR - 3 & "]C)"
  28.         .Cells(xR + 1, 5) = .Cells(xR + 1, 5)
  29.         .Cells(xR + 1, 8) = "=SUM(R[-1]C:R[-" & xR - 3 & "]C)"
  30.         .Cells(xR + 1, 8) = .Cells(xR + 1, 8)
  31.         .Cells(3, 2).Resize(xR - 2).NumberFormatLocal = "@"
  32.         .Cells(3, 2).Resize(xR - 2).FormulaR1C1 = xNO
  33.         'Rows (xR + 1)
  34.         .Rows(xR + 1).Interior.Color = vbYellow
  35.     End With
  36.     MsgBox "ok"
  37. End Sub
複製代碼
作者: s7659109    時間: 2013-9-23 09:43

可能版主誤會我的意思了，套用你的程式碼，有點奇怪，
我希望的結果是工作底稿A001、A002、A003中的貨號
001自動匯入總表內(如總表內的結果)，感溫。
作者: Hsieh    時間: 2013-9-23 11:33

回復 3# s7659109
  1. Sub Import_Data()
  2. Dim Sh As Worksheet, A As Range, Ar(), Ay(0 To 7), s&, Sn$, cnt#, cnt1#
  3. Sn = InputBox("輸入查詢貨號", , "001")
  4. For Each Sh In Sheets
  5. If Sh.Name Like "A*" Then
  6.    With Sh
  7.       For Each A In .Range("B:B").SpecialCells(xlCellTypeConstants)
  8.         If A = Sn Then
  9.             For i = -1 To 6
  10.                Ay(i + 1) = A.Offset(, i)
  11.             Next
  12.            ReDim Preserve Ar(s)
  13.            Ar(s) = Ay
  14.            cnt = cnt + Ay(4)
  15.            cnt1 = cnt1 + Ay(7)
  16.            s = s + 1
  17.         End If
  18.       Next
  19.     End With
  20. End If
  21. Next
  22. With Sheet4
  23. .UsedRange.Offset(2) = ""
  24. If s > 0 Then
  25. ReDim Preserve Ar(s)
  26. Ar(s) = Array("合計", "", "", "", cnt, "", "", cnt1)
  27. s = s + 1
  28. .Columns("B:B").NumberFormat = "@"
  29. .[A3].Resize(s, 8) = Application.Transpose(Application.Transpose(Ar))
  30. Else
  31. MsgBox "無符合資料"
  32. End If
  33. End With
  34. End Sub
複製代碼
作者: s7659109    時間: 2013-9-23 12:37     標題: 如何讓不同檔案同一貨號自動匯入總表

讓A001檔案與A002檔案中的貨號001自動匯入問題10
中總表中(如內顯示)，並依日期自動排序。
作者: s7659109    時間: 2013-9-23 14:01

總表內依然無反應，何故？
作者: s7659109    時間: 2013-9-23 15:19

我已附檔8-3，程式碼已貼上，但總表依然沒反映
請幫我看一下附檔，那裡有錯，謝謝。
作者: Hsieh    時間: 2013-9-23 16:45

回復 5# s7659109
  1. Sub ex()
  2. Dim Sn$, Fs, F, Ar()
  3. Sn = InputBox("請輸入查詢貨號", , "001")
  4. Fs = Application.GetOpenFilename("Excel Files(*.xls),*.xls", , "請選擇檔案(可複選)", , True)
  5. If Not IsArray(Fs) Then MsgBox "請選擇檔案": Exit Sub
  6. For Each F In Fs
  7.    With Workbooks.Open(F)
  8.       With .Sheets(1)
  9.          For Each a In .Range("B:B").SpecialCells(xlCellTypeConstants)
  10.             If a = Sn Then
  11.                ay = a.Offset(, -1).Resize(, 8).Value
  12.                ReDim Preserve Ar(s)
  13.                Ar(s) = ay
  14.                s = s + 1
  15.             End If
  16.          Next
  17.       End With
  18.       .Close 0
  19.     End With
  20. Next
  21. With ThisWorkbook.Sheets("總表")
  22. .UsedRange.Offset(2) = ""
  23. If s > 0 Then
  24.   .[A1] = Sn
  25.   .[A3].Resize(s, 8) = Application.Transpose(Application.Transpose(Ar))
  26.   Else
  27.   MsgBox "沒有符合資料"
  28. End If
  29. End With
  30. End Sub
複製代碼
作者: GBKEE    時間: 2013-9-23 16:52

回復 7# s7659109
加上Sh.
   
               If R.Text = xNO Then
10.                A = Sh.Range("a1").CurrentRegion.Rows(R.Row)
11.                ReDim Preserve AR(1 To i)




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