[發問] 如何讓不同檔案同一貨號自動匯入總表

GBKEE

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

2^#

發表於 2013-9-19 16:51 | 只看該作者

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

回復 1# s7659109
試試看

Sub Ex_特定值彙整到總表()
Dim xNO As String, AR(), A, Sh As Worksheet, R As Range, i As Integer, xR As Integer
xNO = InputBox("輸入貨號")
If xNO = "" Then Exit Sub
i = 1
For Each Sh In Sheets
If InStr(Sh.Name, "A0") = 1 Then
For Each R In Sh.Range("a1").CurrentRegion.Columns("B").Cells
If R.Text = xNO Then
A = Sh.Range("a1").CurrentRegion.Rows(R.Row)
ReDim Preserve AR(1 To i)
AR(i) = A
i = i + 1
End If
Next
End If
Next
If i = 1 Then MsgBox "貨號: 找不到 " & xNO: Exit Sub
With Sheets("總表").Range("A1").CurrentRegion
.Parent.Activate
.Offset(2).Clear
.Range("A3").Resize(i - 1, UBound(A, 2)) = Application.Transpose(Application.Transpose(AR))
xR = Sheets("總表").Range("A1").CurrentRegion.Rows.Count
.Cells(3, 2).Resize(xR - 2).NumberFormatLocal = "@"
.Cells(3, 2).Resize(xR - 2).FormulaR1C1 = xNO
.Cells(xR + 1, 1) = "合計"
.Cells(xR + 1, 5) = "=SUM(R[-1]C:R[-" & xR - 3 & "]C)"
.Cells(xR + 1, 5) = .Cells(xR + 1, 5)
.Cells(xR + 1, 8) = "=SUM(R[-1]C:R[-" & xR - 3 & "]C)"
.Cells(xR + 1, 8) = .Cells(xR + 1, 8)
.Cells(3, 2).Resize(xR - 2).NumberFormatLocal = "@"
.Cells(3, 2).Resize(xR - 2).FormulaR1C1 = xNO
'Rows (xR + 1)
.Rows(xR + 1).Interior.Color = vbYellow
End With
MsgBox "ok"
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

帖子: 248
主題: 76
精華: 0
積分: 331
點名: 0
作業系統: XP
軟體版本: XP
閱讀權限: 20
性別: 男
來自: kaohsiung
註冊時間: 2013-6-10
最後登錄: 2020-7-3

3^#

發表於 2013-9-23 09:43 | 只看該作者

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

Book8-1.rar (8.56 KB)

希望支持!

Hsieh

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 247
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-11-14

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

4^#

發表於 2013-9-23 11:33 | 只看該作者

回復 3# s7659109

Sub Import_Data()
Dim Sh As Worksheet, A As Range, Ar(), Ay(0 To 7), s&, Sn$, cnt#, cnt1#
Sn = InputBox("輸入查詢貨號", , "001")
For Each Sh In Sheets
If Sh.Name Like "A*" Then
With Sh
For Each A In .Range("B:B").SpecialCells(xlCellTypeConstants)
If A = Sn Then
For i = -1 To 6
Ay(i + 1) = A.Offset(, i)
Next
ReDim Preserve Ar(s)
Ar(s) = Ay
cnt = cnt + Ay(4)
cnt1 = cnt1 + Ay(7)
s = s + 1
End If
Next
End With
End If
Next
With Sheet4
.UsedRange.Offset(2) = ""
If s > 0 Then
ReDim Preserve Ar(s)
Ar(s) = Array("合計", "", "", "", cnt, "", "", cnt1)
s = s + 1
.Columns("B:B").NumberFormat = "@"
.[A3].Resize(s, 8) = Application.Transpose(Application.Transpose(Ar))
Else
MsgBox "無符合資料"
End If
End With
End Sub

複製代碼

學海無涯_不恥下問

帖子: 248
主題: 76
精華: 0
積分: 331
點名: 0
作業系統: XP
軟體版本: XP
閱讀權限: 20
性別: 男
來自: kaohsiung
註冊時間: 2013-6-10
最後登錄: 2020-7-3

5^# 倒序看帖

打印

字體大小: tT

發表於 2013-9-23 12:37 | 只看該作者

[發問] 如何讓不同檔案同一貨號自動匯入總表

讓A001檔案與A002檔案中的貨號001自動匯入問題10
中總表中(如內顯示)，並依日期自動排序。

問題10.rar (15.97 KB)

希望支持!

帖子: 248
主題: 76
精華: 0
積分: 331
點名: 0
作業系統: XP
軟體版本: XP
閱讀權限: 20
性別: 男
來自: kaohsiung
註冊時間: 2013-6-10
最後登錄: 2020-7-3

6^#

發表於 2013-9-23 14:01 | 只看該作者

總表內依然無反應，何故？

Book8-2.rar (9.78 KB)

希望支持!

帖子: 248
主題: 76
精華: 0
積分: 331
點名: 0
作業系統: XP
軟體版本: XP
閱讀權限: 20
性別: 男
來自: kaohsiung
註冊時間: 2013-6-10
最後登錄: 2020-7-3

7^#

發表於 2013-9-23 15:19 | 只看該作者

我已附檔8-3，程式碼已貼上，但總表依然沒反映
請幫我看一下附檔，那裡有錯，謝謝。

Book8-3.rar (9.02 KB)

希望支持!

Hsieh

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 247
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-11-14

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

8^#

發表於 2013-9-23 16:45 | 只看該作者

回復 5# s7659109

Sub ex()
Dim Sn$, Fs, F, Ar()
Sn = InputBox("請輸入查詢貨號", , "001")
Fs = Application.GetOpenFilename("Excel Files(*.xls),*.xls", , "請選擇檔案(可複選)", , True)
If Not IsArray(Fs) Then MsgBox "請選擇檔案": Exit Sub
For Each F In Fs
With Workbooks.Open(F)
With .Sheets(1)
For Each a In .Range("B:B").SpecialCells(xlCellTypeConstants)
If a = Sn Then
ay = a.Offset(, -1).Resize(, 8).Value
ReDim Preserve Ar(s)
Ar(s) = ay
s = s + 1
End If
Next
End With
.Close 0
End With
Next
With ThisWorkbook.Sheets("總表")
.UsedRange.Offset(2) = ""
If s > 0 Then
.[A1] = Sn
.[A3].Resize(s, 8) = Application.Transpose(Application.Transpose(Ar))
Else
MsgBox "沒有符合資料"
End If
End With
End Sub

複製代碼

學海無涯_不恥下問

GBKEE

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

9^#

發表於 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)

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.