[發問] 指定資料表

v03586

請想問大大 如下程式碼 如何修改尋找指定的資料表名稱

我有兩個檔案  A檔案是直行檔  B檔案是參考資料來源
B檔案的Excel 名稱不固定 . 但內容的資料表名稱固定 , 如下寫法 只會判斷 B檔案的第一個順位資料表 , 外加判斷第一個資料表 Title 欄位當中的關鍵字
假設資料表順序一調換就無法判斷...想請問大大如何修改即使資料表順序調換也不影響程式判斷呢??

如下程式碼運作是開啟A檔案 與B檔案 , 執行程式後 會將B檔案的資料匯入A檔案指定的工作表欄位
With Workbooks(i).Sheets(1)
If .Range("A" & title_row).Value Like "A*" And .Range("D" & title_row).Value Like "B*" And .Range("E" & title_row) Like "C*"
Set xS = Workbooks(i).Sheets(1)

1. Dim UType%
   
2. Sub 匯入()
   
3. 
   
4. Dim xFile$, x As New Application, xB As Workbook, xS As Worksheet
   
5. Dim RepSht As Worksheet, xR As Range, xLab As Range, xAddress$
   
6. Set RepSht = Sheets("A")
   
7. 
   
8. Application.ScreenUpdating = False
   
9. RepSht.UsedRange.EntireRow.Delete
   
10.     Dim currentPKG, currentDevice, whichFirst As String
    
11.     Dim index As Integer
    
12.     Dim hasReport As Boolean
    
13.     title_row = 1
    
14.     hasReport = False
    
15.     For i = 1 To Workbooks.Count
    
16.         With Workbooks(i).Sheets(1)
    
17.             If .Range("A" & title_row).Value Like "A*" And .Range("D" & title_row).Value Like "B*" And .Range("E" & title_row) Like "C*" Then
    
18.                 Set xS = Workbooks(i).Sheets(1)
    
19.                 hasReport = True
    
20.                 i = Workbooks.Count + 1
    
21.             End If
    
22.         End With
    
23.     Next i
    
24.     If hasReport = False Then MsgBox "找不到檔案！　": Exit Sub
    
25.     R = xS.Cells(Rows.Count, 1).End(xlUp).Row + 5
    
26. With RepSht
    
27.      .Range("A1:A" & R) = xS.Range("D1:D" & R).Value
    
28.      .Range("B1:B" & R) = xS.Range("A1:A" & R).Value
    
29.      .Range("C1:C" & R) = xS.Range("AH1:AH" & R).Value
    
30.      .Range("D1:D" & R) = xS.Range("C1:C" & R).Value
    
31.      .Range("E1:E" & R) = xS.Range("AB1:AB" & R).Value
    
32.      .Range("F1:F" & R) = xS.Range("E1:E" & R).Value  
    
33.      .Range("G1:G" & R) = xS.Range("F1:F" & R).Value
    
34.      .Range("H1:H" & R) = xS.Range("G1:G" & R).Value  
    
35.      .Range("I1:I" & R) = xS.Range("J1:J" & R).Value
    
36.      .Range("J1:Z" & R) = xS.Range("K1:AA" & R).Value
    
37.      .Range("AA1:AA" & R) = xS.Range("AD1:AD" & R).Value
    
38. 
    
39. End With
    
40. End Sub

複製代碼

葉國洲

回復 1# v03586
把"Sheets(1)"裡的1改成工作表名稱就行了

v03586

回復 2# 葉國洲


    With Workbooks(i).Sheets(1) →　With Workbooks(i)."工作表1"

這樣嗎???

starry1314

回復 3# v03586


    With Workbooks(i).Sheets(1) →　With Workbooks(i).Sheets("工作表1")

v03586

回復 4# starry1314


    出現陣列引索超出範圍  錯誤

c_c_lai

回復 5# v03586
你上傳 AB 兩檔案，不就明瞭了？
一般是你工作表定義的名稱找不著。

v03586

回復 6# c_c_lai

要讀取檔案資料表名稱  "H LOT"
開啟兩個Excel 檔  點選產生報表

    Report.rar (1013.15 KB)

下載次數: 9

2016-11-13 16:10

c_c_lai

回復 7# v03586
問題出在

1. Set RepSht = Sheets("FMC")

複製代碼

單獨開啟 "Report_3.xls" 是OK 的。
但是再開啟 "原始檔案.xlsx" 便出問題了，
因為 ActiveWorkbook 改變了。

1. Set RepSht = Workbooks(1).Sheets("FMC")

複製代碼

則 OK。

v03586

回復 8# c_c_lai

我更改這樣 還是出現錯誤耶 , 陣列引索超出範圍
↓
With Workbooks(i).Sheets("H LOT")

1. Dim xFile$, x As New Application, xB As Workbook, xS As Worksheet
   
2. Dim RepSht As Worksheet, xR As Range, xLab As Range, xAddress$
   
3. Set RepSht = Sheets("FMC")
   
4. 
   
5. Sheets("FMC").Activate
   
6. Application.ScreenUpdating = False
   
7. 
   
8. RepSht.UsedRange.EntireRow.Delete
   
9.     Dim currentPKG, currentDevice, whichFirst As String
   
10.     Dim index As Integer
    
11.     Dim hasReport As Boolean
    
12.     title_row = 1
    
13.     hasReport = False
    
14.     For i = 1 To Workbooks.Count
    
15.         With Workbooks(i).Sheets("H LOT")
    
16.             If .Range("A" & title_row).Value Like "MONBR*" And .Range("D" & title_row).Value Like "DEVICE*" And .Range("E" & title_row) Like "PKG*" Then
    
17.                 Set xS = Workbooks(i).Sheets("H LOT")
    
18.                 hasReport = True
    
19.                 i = Workbooks.Count + 1
    
20.             End If
    
21.         End With
    
22.     Next i
    
23.     If hasReport = False Then MsgBox "§ä¤£¨ì³øªíÀÉ¡I¡@": Exit Sub
    
24.     R = xS.Cells(Rows.Count, 1).End(xlUp).Row + 5

複製代碼

c_c_lai

回復 9# v03586

1. Sub 新報表_HQ匯入()
   
2.     'timeStamp = Now
   
3.     Dim xFile$, x As New Application, xB As Workbook, xS As Worksheet
   
4.     Dim RepSht As Worksheet, xR As Range, xLab As Range, xAddress$
   
5.     Set RepSht = Workbooks(1).Sheets("FMC")
   
6.    
   
7.     Sheets("FMC").Activate
   
8.     Application.ScreenUpdating = False
   
9.    
   
10.     RepSht.UsedRange.EntireRow.Delete
    
11.     Dim currentPKG, currentDevice, whichFirst As String
    
12.     Dim index As Integer
    
13.     Dim hasReport As Boolean
    
14.     title_row = 1
    
15. 
    
16.     hasReport = False
    
17.     With Workbooks.Open(ThisWorkbook.Path & "\原始檔案.xlsx")
    
18.         With Sheets("H LOT")
    
19.             If .Range("A" & title_row).Value Like "MONBR*" And .Range("D" & title_row).Value Like "DEVICE*" And .Range("E" & title_row) Like "PKG*" Then
    
20.                 Set xS = Sheets("H LOT")
    
21.                 hasReport = True
    
22.             End If
    
23.         End With
    
24.         If hasReport = False Then MsgBox "找不到報表檔！　": Exit Sub
    
25.         R = xS.Cells(Rows.Count, 1).End(xlUp).Row + 5
    
26.         With RepSht
    
27.             .Range("A1:A" & R) = xS.Range("E1:E" & R).Value  'pkg
    
28.             .Range("B1:B" & R) = xS.Range("A1:A" & R).Value  'MO
    
29.             .Range("C1:C" & R) = xS.Range("G1:G" & R).Value 'MO Lot
    
30.             .Range("D1:D" & R) = xS.Range("S1:S" & R).Value 'Machine
    
31.             .Range("E1:E" & R) = xS.Range("Z1:Z" & R).Value 'PCCode
    
32.             .Range("F1:F" & R) = xS.Range("D1:D" & R).Value         'Device
    
33.             .Range("G1:G" & R) = xS.Range("F1:F" & R).Value  'input Date
    
34.             .Range("H1:H" & R) = xS.Range("M1:M" & R).Value   'DavinciCode
    
35.             .Range("I1:I" & R) = xS.Range("N1:N" & R).Value  'Thickness
    
36.             .Range("J1:J" & R) = xS.Range("AA1:AA" & R).Value  'SitePath
    
37.             .Range("K1:K" & R) = xS.Range("Q1:Q" & R).Value  'WS Tool
    
38.             .Range("L1:L" & R) = xS.Range("R1:R" & R).Value  ' Status
    
39.             .Range("M1:M" & R) = xS.Range("H1:H" & R).Value  'WIP
    
40.             .Range("N1:N" & R) = xS.Range("J1:J" & R).Value  ' WaferPcs
    
41.             .Range("O1:O" & R) = xS.Range("AB1:AB" & R).Value  ' DA Flow
    
42.             .Range("P1:P" & R) = xS.Range("AC1:AC" & R).Value  ' LastMO
    
43.             .Range("Q1:Q" & R) = xS.Range("V1:V" & R).Value  'B/D
    
44.             .Range("R1:AD1") = Split("TBG1,PGH1,WG,LWS1,DE01,FL01,SLS1,WM01,WS01,UTI1,VS01,QVS1,DB,", ",")
    
45.             
    
46.             .Range("AF1:AF" & R) = xS.Range("J1:J" & R).Value  ' WaferPcs Cut
    
47.         End With
    
48.         .Close
    
49.     End With
    
50.     '
    
51.     '
    
52.     '  ***  以下未經修正  ***
    
53.     '
    
54.     '
    
55. End Sub

複製代碼