兩種方案, 自行選用:
Sub TEST_1()
Dim R&, Arr, Brr, i&, S&(1 To 2), V1, V2
R = Cells(Rows.Count, "K").End(xlUp).Row
If R <= 2 Then Exit Sub
Arr = Range("K2:Q" & R)
Brr = Range("M2:N" & R)
For i = 1 To UBound(Arr)
If Arr(i, 1) = "品名" Then Erase S: GoTo 101
If Arr(i, 1) = "合計" Then
Brr(i, 1) = S(1) '箱數合計
Brr(i, 2) = S(2) '瓶數合計
Erase S: GoTo 101
End If
Brr(i, 1) = "": Brr(i, 2) = ""
V1 = Val(Arr(i, 6)) '包裝數
V2 = Val(Arr(i, 7)) '訂購數
If Arr(i, 2) = "" Or V1 = 0 Then GoTo 101
Brr(i, 1) = Int(V2 / V1) '箱數
S(1) = S(1) + Brr(i, 1) '箱數累計
Brr(i, 2) = V2 Mod V1 '瓶數
S(2) = S(2) + Brr(i, 2) '瓶數累計
101: Next i
Range("M2:N" & R) = Brr
End Sub
'============================================
Sub TEST_2()
Dim R&
R = Cells(Rows.Count, "K").End(xlUp).Row
If R <= 2 Then Exit Sub
With Range("M3:N" & R)
.Formula = "=IF($K3=$K$2,M$2,IF($K3=""合計"",SUM(M$1:M2)-SUMIF($K$1:$K2,""合計"",M$1:M2)*2," & _
"IF(($L3="""")+($P3=0),"""",IF(M$2=""箱數"",INT($Q3/$P3),MOD($Q3,$P3)))))"
.Value = .Value
End With
'=============================================
End Sub作者: PJChen 時間: 2020-2-16 18:44
Sub TEST_1()
Dim R&, Arr, Brr, i&, S&(1 To 2), V1, V2, C%
R = Cells(Rows.Count, "K").End(xlUp).Row
If R <= 2 Then Exit Sub
Arr = Range("K2:Q" & R)
Brr = Range("M2:N" & R)
For i = 1 To UBound(Arr)
If Arr(i, 1) = "品名" Then Erase S: C = 1: GoTo 101
If Arr(i, 1) = "合計" Then
Brr(i, 1) = S(1) '箱數合計
Brr(i, 2) = S(2) '瓶數合計
Erase S: C = 0: GoTo 101
End If
If C = 1 Then
Brr(i, 1) = "": Brr(i, 2) = ""
V1 = Val(Arr(i, 6)) '包裝數
V2 = Val(Arr(i, 7)) '訂購數
If Arr(i, 2) = "" Or V1 = 0 Then GoTo 101
Brr(i, 1) = Int(V2 / V1) '箱數
S(1) = S(1) + Brr(i, 1) '箱數累計
Brr(i, 2) = V2 Mod V1 '瓶數
S(2) = S(2) + Brr(i, 2) '瓶數累計
End If
101: Next i
Range("M2:N" & R) = Brr
End Sub
Sub TEST_2()
Dim R&, xR As Range, xH As Range, C%
R = Cells(Rows.Count, "K").End(xlUp).Row
If R <= 2 Then Exit Sub
For Each xR In Range("K2:K" & R)
If xR = "品名" Then Set xH = xR(2, 3): C = 1: GoTo 101
If xR = "合計" Then
If C = 0 Then GoTo 101
With Range(xH, xR(0, 4))
.Columns(1).FormulaR1C1 = "=IF(OR(RC[-1]="""",N(RC[3])=0),"""",INT(RC[4]/RC[3]))"
.Columns(2).FormulaR1C1 = "=IF(OR(RC[-2]="""",N(RC[2])=0),"""",MOD(RC[3],RC[2]))"
.Value = .Value
End With
xR(1, 3) = "=SUM(" & Range(xH(1, 1), xR(0, 3)).Address & ")" '箱數合計公式
xR(1, 4) = "=SUM(" & Range(xH(1, 2), xR(0, 4)).Address & ")" '瓶數合計公式
xR(1, 7) = "=SUM(" & Range(xH(1, 5), xR(0, 7)).Address & ")" '訂購數 合計公式
C = 0
End If
101: Next
End Sub
Sub 訂購數_清除()
Dim R&, xR As Range, xH As Range, C%
R = Cells(Rows.Count, "K").End(xlUp).Row
If R <= 2 Then Exit Sub
For Each xR In Range("K2:K" & R)
If xR = "品名" Then Set xH = xR(2): C = 1: GoTo 101
If xR = "合計" Then
If C = 0 Then GoTo 101
Range(xH(1, 7), xR(0, 7)).ClearContents
C = 0
End If
101: Next
End Sub
Sub 允收日_公式()
Dim R&, xR As Range, xH As Range, C%, Fx$(1 To 3), j%
R = Cells(Rows.Count, "K").End(xlUp).Row
If R <= 2 Then Exit Sub
Fx(1) = "=IF(J3="""","""",J3-U3)"
Fx(2) = "=IF(J3="""","""",""~"")"
Fx(3) = "=IF(N(B$_X)*LEN(K3)*N(T3)*N(U3)=0,"""",B$_X+T3-1)"
For Each xR In Range("K2:K" & R)
If xR = "品名" Then Set xH = xR(2, -2): C = 1: GoTo 101
If xR = "合計" Then
If C = 0 Then GoTo 101
For j = 1 To 3
Range(xH(1, j), xR(0, -3 + j)) = Replace(Replace(Fx(j), 3, xH.Row), "_X", xH.Row - 2)
Next j
C = 0
End If
101: Next
End Sub
Sub 允收日_清除()
Dim R&, xR As Range, xH As Range, C%
R = Cells(Rows.Count, "K").End(xlUp).Row
If R <= 2 Then Exit Sub
For Each xR In Range("K2:K" & R)
If xR = "品名" Then Set xH = xR(2, -2): C = 1: GoTo 101
If xR = "合計" Then
If C = 0 Then GoTo 101
Range(xH, xR(0, 0)).ClearContents
C = 0
End If
101: Next
End Sub
Sub 允收日_公式()
Dim R&, xR As Range, xH As Range, C%, Fx$(1 To 3), j%
R = Cells(Rows.Count, "K").End(xlUp).Row
If R <= 2 Then Exit Sub
Fx(1) = "=IF(J3="""","""",J3-U3-V3)"
Fx(2) = "=IF(J3="""","""",""~"")"
Fx(3) = "=IF(OR(B$_X="""",K3=""""),"""",B$_X+T3-1)"
For Each xR In Range("K2:K" & R)
If xR = "品名" Then Set xH = xR(2, -2): C = xH.Row: GoTo 101
If xR = "合計" Then
If C = 0 Then GoTo 101
For j = 1 To 3
Range(xH(1, j), xR(0, -3 + j)) = Replace(Replace(Fx(j), 3, C), "_X", C - 2)
Next j
With Range(xH, xR(0, 0)): .Value = .Value: End With
C = 0
End If
101: Next
End Sub
Sub 劃單_公式()
Dim Rw&, xR As Range, xH As Range, C%, Fx$
Rw = Cells(Rows.Count, "K").End(xlUp).Row
If Rw <= 2 Then Exit Sub
[R2] = "=-SUMPRODUCT(([最新庫存.xlsx]飛比!$F$4:$F$70=$L2)*([最新庫存.xlsx]飛比!$CD$3:$CV$3=$B2)*([最新庫存.xlsx]飛比!$CD$4:$CV$70))"
For Each xR In Range("K2:K" & Rw)
If xR = "品名" Then Set xH = xR(2, 8): C = 1: GoTo 101
If xR = "合計" Then
If C = 0 Then GoTo 101
With Range(xH, xR(0, 8)) 'R欄填入公式
.FormulaR1C1 = [R2].FormulaR1C1
.Value = .Value
.Replace 0, "", 1 '*****(1,完全符合)
End With
C = 0
End If
101: Next
[R2] = ""
End Sub
If Rw <= 2 Then Exit Sub
If xR = "品名" Then Set xH = xR(2, 8): C = 1: GoTo 101
If xR = "合計" Then
If C = 0 Then GoTo 101
With Range(xH, xR(0, 8))
.Replace 0, "", 1....這裡已經把0取代為空白,為什麼還需要[R2] = ""作者: 准提部林 時間: 2020-4-6 12:15
也可以這樣:
Sub 廠缺載入()
Dim Rw&, xR As Range, xH As Range, C%, Fx$, LT$
Workbooks("理貨單II.xlsx").Sheets("BF理貨").Activate
Rw = Cells(Rows.Count, "K").End(xlUp).Row
If Rw <= 2 Then Exit Sub
LT = [F2].Value
[F2] = "=IF(SUMPRODUCT(([最新庫存.xlsx]飛比!$BJ$3:$CB$3=$B2)*([最新庫存.xlsx]飛比!$F$4:$F$64=$L2)*([最新庫存.xlsx]飛比!$BJ$4:$CB$64))=0,"""",IF(SUMPRODUCT(([最新庫存.xlsx]飛比!$BJ$3:$CB$3=$B2)*([最新庫存.xlsx]飛比!$F$4:$F$64=$L2)*([最新庫存.xlsx]飛比!$BJ$4:$CB$64))=$Q2,""廠缺"",""缺""&SUMPRODUCT(([最新庫存.xlsx]飛比!$BJ$3:$CB$3=$B2)*([最新庫存.xlsx]飛比!$F$4:$F$64=$L2)*([最新庫存.xlsx]飛比!$BJ$4:$CB$64))))"
For Each xR In Range("K2:K" & Rw)
If xR = "品名" Then Set xH = xR(2, -4): C = 1: GoTo 101
If xR = "合計" Then
If C = 0 Then GoTo 101
With Range(xH, xR(0, -4)) 'F欄填入公式
.FormulaR1C1 = [F2].FormulaR1C1
.Value = .Value
.Replace 0, "", 1 '*****(1,完全符合)
End With
C = 0
End If
101: Next
[F2].Value = LT
End Sub
回復 50#PJChen
試試看!!
Sub ex()
Dim x%, i%
Dim xR As Object
For Each xR In Range([b5], [b65535].End(3))
If xR = "訂單" Or xR = "廠缺" Or xR = "實出數" Then
For i = 1 To 8
If xR.Offset(, i) <> 0 Then
x = Application.WorksheetFunction.Quotient(xR.Offset(, i), [C3]) '計算箱數
xR.Offset(, i) = xR.Offset(, i) & "=" & vbCrLf & x & "箱+" & xR.Offset(, i) Mod [C3]
End If
Next
End If
Next
End Sub作者: PJChen 時間: 2020-5-11 16:16
Sub ex()
Dim d As Object
Set d = CreateObject("Scripting.Dictionary")
For Each a In Range("B:B")
If a = "林口" Then d(a.Address) = d(a.Address) '抓林口的位置,廠商自行更換
Next
Range(d.Keys()(0)).Offset(, 5).Resize(d.Count, 10).Select '選擇範圍,請自行加入複製到哪的程式
End Sub作者: PJChen 時間: 2020-5-22 20:52
Sub 理貨排序()
Dim R&, xR As Range, xH As Range, C%, V&
R = Cells(Rows.Count, "K").End(xlUp).Row
If R <= 2 Then Exit Sub
For Each xR In Range("K2:K" & R)
If xR = "品名" Then Set xH = xR(2): C = 1: V = 0: GoTo 101
V = V + Val(xR(1, -4))
If xR = "合計" Then
If C = 0 Or V = 0 Then GoTo 101
With Range(xH(1, -4), xR(0, 7))
.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, _
Key2:=.Cells(1, 7), Order2:=xlAscending, Header:=xlNo
End With
C = 0: V = 0
End If
101: Next
End Sub作者: PJChen 時間: 2020-5-23 21:39
Sub 理貨排序()
Dim R&, xR As Range, xH As Range, C%, V&
R = Cells(Rows.Count, "K").End(xlUp).Row
If R <= 2 Then Exit Sub
Application.ScreenUpdating = False
For Each xR In Range("K2:K" & R)
If xR = "品名" Then Set xH = xR(2): C = 1: V = 0: GoTo 101
V = V + Val(xR(1, -4))
If xR = "合計" Then
If C = 0 Or V = 0 Then GoTo 101
Range(xH(1, -4), xR(0, -4)).Replace "", "ZZ", Lookat:=xlWhole '將空字符取代為"ZZ"
With Range(Rows(xH.Row), Rows(xR(0).Row))
.Sort Key1:=.Cells(1, "F"), Order1:=xlAscending, _
Key2:=.Cells(1, "L"), Order2:=xlAscending, Header:=xlNo
End With
Range(xH(1, -4), xR(0, -4)).Replace "ZZ", "", Lookat:=xlWhole '將"ZZ取代為空
C = 0: V = 0
End If
101: Next
End Sub
您好,
原程式寫法都是從第3列開始更新公式,隨著資料持續增加,
更新時間越來越長,且函數寫成的公式很冗長,想改為非函數的寫法,
檔案每次更新後,公式便值化,除非有變動資料,否則不需要每次都從第3列開始更新公式,
所以我在"VBA".sheet的[AA3]指定一個日期,當B欄>=這個日期的資料才需要更新,
我依照這個模式,改了第一個"月份"欄,執行沒問題,但要套到以下11種不同公式的寫法,
If xR = "月份" Or xR = "採購單號碼" Or xR = "結餘" Or xR = "大" Or xR = "美" Or xR = "大中南區" Or xR = "美中南區" Or xR = "派板對應單據日" Or xR = "派板-交板差異" Or xR = "派板結餘" Or xR = "盤點差異"
卻不知如何下手,以下是原程式, 可否幫忙看下,要如何修改? [attach]32193[/attach]
Sub 北區_公式更新()
Dim Sh As Worksheet, xS As Worksheet, xR
Set xS = ThisWorkbook.Sheets("VBA") '程式來源
Set Sh = Workbooks("全省核銷明細.xlsx").Sheets("北區")
d = xS.[AA3] 'Date
Sh.Activate
'------------ 'A 取出B欄年.月,這段是依照您的程式修改後的
For Each xR In Range([b3], [b65535].End(3)) '向上 End(3) = End(xlup).Row
您好,
先說聲謝謝,你寫的程式,總是讓我得到很大的啟發
這段程式,我稍作修改,希望它可以自動對應,增加方便性,
但有些二個問題我無法解決...程式已寫入macro_D [attach]32231[/attach]
macro_D的"理貨單"工作表,W1 & W2的對應值
x1 = xS.[w1] '對應 活動範圍a
x2 = xS.[w2] '對應檔名
For k = 1 To 7 (原7個檔,先用"下個月理貨單"資料夾的2個檔測試)
xS.[V1] = k
當xS.[w1]=1="暖暖1"
xS.[w2]="暖暖",則打開公用理貨含有"暖暖"字樣的檔案,
將理貨單II的B欄="暖暖1"的儲存格F:P的資料,
copy到"1"工作表的B3貼上值,
使用時發現程式copy資料並不是很快速
For Each a In Range("B:B")
If a = x1 Then d(a.Address) = d(a.Address)
所以我是用理貨單II的F:P區域覆蓋B:L,想使copy一次完成,
然後再將D:F,I:J的公式代入後下拉
現在遇到問題如下：
1) 雖然寫了
For k = 1 To 7
xS.[V1] = k
但它只會打開第一個檔,我要如何讓它把"下個月理貨單"資料夾,全部檔都依序打開,
然後依k = 1 To 7,所對應的值貼到該貼的地方?
Sub 理貨訂購量()
Dim Rw&, xR As Range, xD, xH As Range, c$, Fx$
Rw = Cells(Rows.Count, "K").End(xlUp).Row
If Rw <= 2 Then Exit Sub
Set xD = CreateObject("Scripting.Dictionary")
xD("全都") = "=SUMIFS(網單.全都!$I:$I,網單.全都!$C:$C,BF理貨!$D2," & _
"網單.全都!$K:$K,BF理貨!$C2)+IF(BF理貨!$R$283=BF理貨!$B$283,BF理貨!$R2,0)"
xD("統統") = "=SUMIFS(網單.統統!$R:$R,網單.統統!$M:$M,BF理貨!$D2,網單.統統!$AC:$AC,BF理貨!$C2," & _
"網單.統統!$AE:$AE,BF理貨!$B$1)+IF(BF理貨!$R$1=BF理貨!$B$1,BF理貨!$R2,0)"
xD("德QQK") = "=SUMIF(網單.德QQK!$E:$E,BF理貨!$D2,網單.德QQK!$G:$G)+IF(BF理貨!$R$388=BF理貨!$B$388,BF理貨!$R2,0)"
xD("M社") = "=SUMPRODUCT((網單.M社!$R$2:$R$300=BF理貨!$D2)*(網單.M社!$AP$2:$AP$300))+" & _
"IF(BF理貨!$R$561=BF理貨!$B$561,BF理貨!$R2,0)"
xD("得來") = "=SUMIFS(網單.得來!$L:$L,網單.得來!$H:$H,BF理貨!$D2,網單.得來!$O:$O,BF理貨!$C2)" & _
"+IF(BF理貨!$R$420=BF理貨!$B$420,BF理貨!$R2,0)"
xD("W康") = "=SUMPRODUCT((網單.W康!$C$6:$C$298=BF理貨!$D2)*(網單.W康!$D$6:$D$298))+" & _
"IF(BF理貨!$R$508=BF理貨!$B$508,BF理貨!$R2,0)"
For Each xR In Range("K2:K" & Rw)
If xR = "品名" Then Set xH = xR(2, 7): c = Range("A" & xR.Row): GoTo 101
If xR = "合計" Then
Fx = xD(c)
If c = "" Or Fx = "" Then GoTo 101
[Q2].Formula = Fx
With Range(xH, xR(0, 7)) 'Q欄填入公式
.FormulaR1C1 = [Q2].FormulaR1C1
.Value = .Value
.Replace 0, "", 1 '*****(1,完全符合)
End With
c = ""
End If
101: Next
[Q2] = "訂購數"
End Sub
