標題:
[發問]
自動加入母檔
[打印本頁]
作者:
adam2010
時間:
2013-7-6 17:40
標題:
自動加入母檔
本帖最後由 adam2010 於 2013-7-6 17:43 編輯
請教各位高手，我有一個檔案在做完交期彙總樞紐分析轉值後(如下圖)需要加入母檔，不知是否可寫成巨集
加入母檔個規則如下~
※只要料號有尾碼不等於X的就要在那個群組下方增加一列母檔(如下紅底的尾碼=X)
※母檔的可用庫存(籃底部分)=所有子檔的可用庫存+1300+在製量NEW
※母檔的VAR(灰底)公式跟子檔或其他料號相同=總計-可用庫存NEW(總計的欄位不是固定的，但是一定在最右邊)
※母檔每個日期(日期不是連續的，而且總欄數也不一定)數量=所有子檔的加總(水藍底色)
[attach]15378[/attach]
加入後如下~
[attach]15380[/attach]
[attach]15379[/attach]
作者:
GBKEE
時間:
2013-7-7 09:32
回復
1#
adam2010
試試看
Option Explicit
Sub Ex()
Dim Rng(1 To 2) As Range, M As String, R As Integer
With ActiveSheet
Set Rng(1) = .Range("A2") '物件: A2儲存格
R = .[A1].End(xlToRight).Column '數值: A1往右到最後有數值的欄號
Do
If InStrRev(Rng(1), "X") <> Len(Rng(1)) And M = "" Then '儲存格右邊第一個字串<>"X" 且 M = ""
M = Mid(Rng(1), 1, Len(Rng(1)) - 1) 'M = 去掉儲存格右邊第一個字串的字串
Set Rng(2) = Rng(1) '物件 Rng(2) :第1 個子檔位置
ElseIf M <> "" And Rng(1) = M & "X" Then '儲存格右邊第一個字串="X"
M = "" '是母檔 : M=""
ElseIf M <> "" And M <> Mid(Rng(1), 1, Len(Rng(1)) - 1) Then '讀完相同的子檔
Rng(1).EntireRow.Insert '使用插入方法,Rng(1)會下移
Set Rng(1) = Rng(1).Offset(-1) '母檔的位置
Set Rng(2) = Range(Rng(1).Offset(-1), Rng(2)) '所有子檔的範圍
With Rng(1)
.Cells = M & "X"
.Cells(1, "H").Resize(1, R - 8) = "=SUM(R[-1]C:R[-" & Rng(2).Rows.Count & "]C)"
' R - 8 : H欗到 A1往右到最後有數值的欄號 - 1欗
.Cells(1, "H").Resize(1, R - 8) = .Cells(1, "H").Resize(1, R - 8).Value
.Cells(1, R) = Application.Sum(.Cells(1, 8).Resize(1, R - 8))
.Cells(1, "D") = Application.Sum(Rng(2).Range("D1:F" & Rng(2).Rows.Count))
.Cells(1, "G") = .Cells(1, "D") - .Cells(1, R)
End With
M = ""
End If
Set Rng(1) = Rng(1).Offset(1) '物件 Rng(1)移往下一列
Loop Until Rng(1) = ""
End With
End Sub
複製代碼
作者:
adam2010
時間:
2013-7-7 21:25
感謝GBKEE大的回覆，完全符合需求
如果我想要將加入的母檔加上底色以示區別是不是加在第18行後面就可以了，謝謝！
作者:
GBKEE
時間:
2013-7-8 06:41
回復
3#
adam2010
Option Explicit
Sub Ex()
Dim Rng(1 To 2) As Range, M As String, R As Integer
With ActiveSheet
Set Rng(1) = .Range("A2") '物件: A2儲存格
R = .[A1].End(xlToRight).Column '數值: A1往右到最後有數值的欄號
Do
If InStrRev(Rng(1), "X") <> Len(Rng(1)) And M = "" Then '儲存格右邊第一個字串<>"X" 且 M = ""
M = Mid(Rng(1), 1, Len(Rng(1)) - 1) 'M = 去掉儲存格右邊第一個字串的字串
Set Rng(2) = Rng(1) '物件 Rng(2) :第1 個子檔位置
ElseIf InStrRev(Rng(1), "X") = Len(Rng(1)) Then '是母檔
Rng(1).Resize(1, R).Interior.Color = vbGreen '***加入底色
M = "" '是母檔 : M=""
ElseIf M <> "" And M <> Mid(Rng(1), 1, Len(Rng(1)) - 1) Then '讀完相同的子檔
Rng(1).EntireRow.Insert '使用插入方法,Rng(1)會下移
Set Rng(1) = Rng(1).Offset(-1) '母檔的位置
Set Rng(2) = Range(Rng(1).Offset(-1), Rng(2)) '所有子檔的範圍
With Rng(1)
.Resize(1, R).Interior.Color = vbGreen '***加入底色
.Cells = M & "X"
.Cells(1, "H").Resize(1, R - 8) = "=SUM(R[-1]C:R[-" & Rng(2).Rows.Count & "]C)"
' R - 8 : H欗到 A1往右到最後有數值的欄號 - 1欗
.Cells(1, "H").Resize(1, R - 8) = .Cells(1, "H").Resize(1, R - 8).Value
.Cells(1, R) = Application.Sum(.Cells(1, 8).Resize(1, R - 8))
.Cells(1, "D") = Application.Sum(Rng(2).Range("D1:F" & Rng(2).Rows.Count))
.Cells(1, "G") = .Cells(1, "D") - .Cells(1, R)
End With
M = ""
End If
Set Rng(1) = Rng(1).Offset(1) '物件 Rng(1)移往下一列
Loop Until Rng(1) = ""
End With
End Sub
複製代碼
作者:
adam2010
時間:
2013-7-8 20:25
感謝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欗
歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)
