Board logo

標題: [發問] 指定資料表 [打印本頁]
作者: v03586    時間: 2016-11-3 06:06     標題: 指定資料表

本帖最後由 v03586 於 2016-11-3 06:07 編輯

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

我有兩個檔案  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 匯入()

  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")

  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

  39. End With
  40. End Sub
複製代碼
作者: 葉國洲    時間: 2016-11-9 09:31

回復 1# v03586
把"Sheets(1)"裡的1改成工作表名稱就行了
作者: v03586    時間: 2016-11-11 03:17

回復 2# 葉國洲


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

這樣嗎???
作者: starry1314    時間: 2016-11-11 10:26

回復 3# v03586


    With Workbooks(i).Sheets(1) →　With Workbooks(i).Sheets("工作表1")
作者: v03586    時間: 2016-11-12 23:50

回復 4# starry1314


    出現陣列引索超出範圍  錯誤
作者: c_c_lai    時間: 2016-11-13 07:05

回復 5# v03586
你上傳 AB 兩檔案，不就明瞭了？
一般是你工作表定義的名稱找不著。
作者: v03586    時間: 2016-11-13 16:12

回復 6# c_c_lai

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

    [attach]25798[/attach]
作者: c_c_lai    時間: 2016-11-13 18:01

回復 7# v03586
問題出在
  1. Set RepSht = Sheets("FMC")
複製代碼
單獨開啟 "Report_3.xls" 是OK 的。
但是再開啟 "原始檔案.xlsx" 便出問題了，
因為 ActiveWorkbook 改變了。
  1. Set RepSht = Workbooks(1).Sheets("FMC")
複製代碼
則 OK。
作者: v03586    時間: 2016-11-13 20:12

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

  5. Sheets("FMC").Activate
  6. Application.ScreenUpdating = False

  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    時間: 2016-11-14 07:41

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

  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
複製代碼




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