[發問] 自動加入母檔

adam2010

請教各位高手，我有一個檔案在做完交期彙總樞紐分析轉值後(如下圖)需要加入母檔，不知是否可寫成巨集
加入母檔個規則如下~
※只要料號有尾碼不等於X的就要在那個群組下方增加一列母檔(如下紅底的尾碼=X)
※母檔的可用庫存(籃底部分)=所有子檔的可用庫存+1300+在製量NEW
※母檔的VAR(灰底)公式跟子檔或其他料號相同=總計-可用庫存NEW(總計的欄位不是固定的，但是一定在最右邊)
※母檔每個日期(日期不是連續的，而且總欄數也不一定)數量=所有子檔的加總(水藍底色)

下載 (76.68 KB)

2013-7-6 17:38

加入後如下~

下載 (141.47 KB)

2013-7-6 17:43

增加母檔問題.rar (12.2 KB)

下載次數: 5

2013-7-6 17:38

GBKEE

回復 1# adam2010
試試看

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Rng(1 To 2) As Range, M As String, R As Integer
   
4.     With ActiveSheet
   
5.         Set Rng(1) = .Range("A2")                                               '物件: A2儲存格
   
6.         R = .[A1].End(xlToRight).Column                                         '數值: A1往右到最後有數值的欄號
   
7.         Do
   
8.             If InStrRev(Rng(1), "X") <> Len(Rng(1)) And M = "" Then             '儲存格右邊第一個字串<>"X" 且 M = ""
   
9.                 M = Mid(Rng(1), 1, Len(Rng(1)) - 1)                             'M = 去掉儲存格右邊第一個字串的字串
   
10.                 Set Rng(2) = Rng(1)                                             '物件 Rng(2) :第1 個子檔位置
    
11.             ElseIf M <> "" And Rng(1) = M & "X" Then                            '儲存格右邊第一個字串="X"
    
12.                 M = ""                                                          '是母檔 : M=""
    
13.             ElseIf M <> "" And M <> Mid(Rng(1), 1, Len(Rng(1)) - 1) Then        '讀完相同的子檔
    
14.                 Rng(1).EntireRow.Insert                                         '使用插入方法,Rng(1)會下移
    
15.                 Set Rng(1) = Rng(1).Offset(-1)                                  '母檔的位置
    
16.                 Set Rng(2) = Range(Rng(1).Offset(-1), Rng(2))                   '所有子檔的範圍
    
17.                 With Rng(1)
    
18.                     .Cells = M & "X"
    
19.                     .Cells(1, "H").Resize(1, R - 8) = "=SUM(R[-1]C:R[-" & Rng(2).Rows.Count & "]C)"
    
20.                     ' R - 8 :  H欗到 A1往右到最後有數值的欄號 - 1欗
    
21.                     .Cells(1, "H").Resize(1, R - 8) = .Cells(1, "H").Resize(1, R - 8).Value
    
22.                     .Cells(1, R) = Application.Sum(.Cells(1, 8).Resize(1, R - 8))
    
23.                     .Cells(1, "D") = Application.Sum(Rng(2).Range("D1:F" & Rng(2).Rows.Count))
    
24.                     .Cells(1, "G") = .Cells(1, "D") - .Cells(1, R)
    
25.                 End With
    
26.                 M = ""
    
27.             End If
    
28.             Set Rng(1) = Rng(1).Offset(1)                                           '物件 Rng(1)移往下一列
    
29.         Loop Until Rng(1) = ""
    
30.     End With
    
31. End Sub

複製代碼

adam2010

感謝GBKEE大的回覆，完全符合需求
如果我想要將加入的母檔加上底色以示區別是不是加在第18行後面就可以了，謝謝！

GBKEE

回復 3# adam2010

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Rng(1 To 2) As Range, M As String, R As Integer
   
4.     With ActiveSheet
   
5.         Set Rng(1) = .Range("A2")                                               '物件: A2儲存格
   
6.         R = .[A1].End(xlToRight).Column                                         '數值: A1往右到最後有數值的欄號
   
7.         Do
   
8.             If InStrRev(Rng(1), "X") <> Len(Rng(1)) And M = "" Then             '儲存格右邊第一個字串<>"X" 且 M = ""
   
9.                 M = Mid(Rng(1), 1, Len(Rng(1)) - 1)                             'M = 去掉儲存格右邊第一個字串的字串
   
10.                 Set Rng(2) = Rng(1)                                             '物件 Rng(2) :第1 個子檔位置
    
11.             ElseIf InStrRev(Rng(1), "X") = Len(Rng(1)) Then                     '是母檔
    
12.                 Rng(1).Resize(1, R).Interior.Color = vbGreen                    '***加入底色
    
13.                 M = ""                                                          '是母檔 : M=""
    
14.             ElseIf M <> "" And M <> Mid(Rng(1), 1, Len(Rng(1)) - 1) Then        '讀完相同的子檔
    
15.                 Rng(1).EntireRow.Insert                                         '使用插入方法,Rng(1)會下移
    
16.                 Set Rng(1) = Rng(1).Offset(-1)                                  '母檔的位置
    
17.                 Set Rng(2) = Range(Rng(1).Offset(-1), Rng(2))                   '所有子檔的範圍
    
18.                 With Rng(1)
    
19.                     .Resize(1, R).Interior.Color = vbGreen                      '***加入底色
    
20.                     .Cells = M & "X"
    
21.                     .Cells(1, "H").Resize(1, R - 8) = "=SUM(R[-1]C:R[-" & Rng(2).Rows.Count & "]C)"
    
22.                     ' R - 8 :  H欗到 A1往右到最後有數值的欄號 - 1欗
    
23.                     .Cells(1, "H").Resize(1, R - 8) = .Cells(1, "H").Resize(1, R - 8).Value
    
24.                     .Cells(1, R) = Application.Sum(.Cells(1, 8).Resize(1, R - 8))
    
25.                     .Cells(1, "D") = Application.Sum(Rng(2).Range("D1:F" & Rng(2).Rows.Count))
    
26.                     .Cells(1, "G") = .Cells(1, "D") - .Cells(1, R)
    
27.                 End With
    
28.                 M = ""
    
29.             End If
    
30.             Set Rng(1) = Rng(1).Offset(1)                                           '物件 Rng(1)移往下一列
    
31.         Loop Until Rng(1) = ""
    
32.     End With
    
33. End Sub

複製代碼

adam2010

感謝GBKEE大的回覆，這樣加的話所有子檔會有底色
我是在母檔加入後加上顏色，應該也OK吧!               
  With Rng(1)
    .Cells = M & "X"
                   .Cells.Select
                   With Selection.Interior
                       .Color = vbGreen
                   End With         
                  
                   .Cells(1, "B") = .Cells(1, "B").Offset(-1)
                   .Cells(1, "C") = .Cells(1, "C").Offset(-1)
                   '沿用子檔的吋別&摻值
                  
                   .Cells(1, "H").Resize(1, R - 8) = "=SUM(R[-1]C:R[-" & Rng(2).Rows.Count & "]C)"
                   ' R - 8 :  H欗到 A1往右到最後有數值的欄號 - 1欗