"總表內容依照條件複製到另個活頁簿"

eg0802

範例.rar (33.03 KB)

下載次數: 16

2013-5-21 14:07

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

GBKEE

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

回復 2# GBKEE


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

GBKEE

回復 3# eg0802
顯示"超出陣列索引範圍"  :是哪一行程式碼  
由於每張ws的表頭是"固定"但表尾不一定固定:  ws的表頭是"固定" 是指那裡

Hsieh

回復 3# eg0802
試試看，由巨集執行開啟總資料檔案
執行後會產生以日期命名的分類檔案
總表範本.rar (22.59 KB)

下載次數: 19

2013-5-21 22:40

eg0802

回復 5# Hsieh


    感恩H大  可以用!! ^^