Board logo

標題: "總表內容依照條件複製到另個活頁簿" [打印本頁]
作者: eg0802    時間: 2013-5-21 14:06     標題: "總表內容依照條件複製到另個活頁簿"

本帖最後由 GBKEE 於 2013-5-21 15:04 編輯

[attach]15046[/attach]哈瞜.各位...小弟又上來求救了....!!!   附件有兩個EXCEL檔
1. JZT BC-總表
2. 總訂單數量
小弟想將"總訂單數量"的資訊  按照WS號碼拆成各個工作表並通通放在總表(活頁簿)中   再依照顏色填進各個工作表中   WS16002是完成的樣子..............大幫忙...Orz...
作者: GBKEE    時間: 2013-5-21 16:39

本帖最後由 GBKEE 於 2013-5-21 16:42 編輯

回復 1# eg0802
[JZT BC-總表] 請先建立一工作表(範本 :115602的表格) 多餘的工作表可刪除掉
  1. Option Explicit
  2. Dim WB(1 To 2) As Workbook
  3. Sub EX()
  4.     Dim R(1 To 2) As Range
  5.     Set WB(1) = Workbooks("總訂單數量.xls")
  6.     Set WB(2) = Workbooks("JZT BC-總表.xls")
  7.     With WB(1).Sheets(1)
  8.         Set R(1) = .Range("B3", .[B3].End(xlDown))
  9.         R(1).AdvancedFilter xlFilterCopy, , .Cells(1, .Rows.Columns.Count), True
  10.         Set R(2) = .Cells(2, .Rows.Columns.Count)
  11.         Do While R(2) <> ""
  12.             With R(1)
  13.                 .Replace R(2), "=AAA", xlWhole
  14.                 With .SpecialCells(xlCellTypeFormulas, xlErrors)
  15.                     .Name = "WS"
  16.                     .Value = R(2)
  17.                 End With
  18.             End With
  19.             資料匯入 R(2).Value, Range("WS")
  20.             Set R(2) = R(2).Offset(1)
  21.         Loop
  22.     End With
  23.     WB(2).Save
  24. End Sub
  25. Private Sub 資料匯入(Sh_Name As String, Rng As Range)
  26.    Dim R As Integer
  27.      On Error GoTo L
  28.      R = Rng.Columns(10).Rows.Count
  29.     With WB(2).Sheets(Sh_Name)        '工作表不存在會有錯
  30.         .[B24] = Rng.Cells(1, 9)
  31.         .[I6] = Sh_Name
  32.         With .[A30:G60]
  33.             .Cells = ""
  34.             .Cells(1, "A").Resize(R, 1) = Rng.Columns(11).Value
  35.             .Cells(1, "B").Resize(R, 1) = Rng.Columns(3).Value
  36.             .Cells(1, "C").Resize(R, 1) = Rng.Columns(6).Value
  37.             .Cells(1, "E").Resize(R, 1) = Rng.Columns(4).Value
  38.             .Cells(1, "F").Resize(R, 1) = Rng.Columns(5).Value
  39.         End With
  40.     End With
  41.     Exit Sub
  42. L:
  43.     With Workbooks("JZT BC-總表.xls")
  44.          .Sheets("範本").Copy , .Sheets(1)
  45.         ActiveSheet.Name = Sh_Name
  46.     End With
  47.     Resume
  48. End Sub
複製代碼
作者: eg0802    時間: 2013-5-21 17:42

回復 2# GBKEE


    感謝g大的回覆  小弟照了您的方法  顯示"超出陣列索引範圍"   
補充說明 : 由於每張ws的表頭是"固定"但表尾不一定固定(會隨著sty 變多而增加列數)  是否會有影響?
作者: GBKEE    時間: 2013-5-21 17:48

回復 3# eg0802
顯示"超出陣列索引範圍"  :是哪一行程式碼  
由於每張ws的表頭是"固定"但表尾不一定固定:  ws的表頭是"固定" 是指那裡
作者: Hsieh    時間: 2013-5-21 22:43

回復 3# eg0802
試試看，由巨集執行開啟總資料檔案
執行後會產生以日期命名的分類檔案
[attach]15051[/attach]
作者: eg0802    時間: 2013-5-22 14:01

回復 5# Hsieh


    感恩H大  可以用!! ^^



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