麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 指定日期計算結餘數 [打印本頁]

作者: PJChen 時間: 2021-9-22 21:20 標題: 指定日期計算結餘數

大大好,
請教
北區的資料是整年度的,資料會不斷增加,
B欄的日期>=VBA工作表的AF2
則計算K欄的結餘數
K3=k2+g3-f3-h3-i3+j3
原程式寫法是
For Each xR In Range([B3], [b65535].End(3))
If xR >= d Then 'k+g-f-h-i+j
xR.Offset(, 9) = xR.Offset(-1, 9) + xR.Offset(, 5) - xR.Offset(, 4) - xR.Offset(, 6) - xR.Offset(, 7) + xR.Offset(, 8)
End If
Next
結果會變成值,但有時需要保留公式,
並且我這種寫法,覺得不好用,
請問大大,如何改善程式?
需要有2種寫法
1. 計算後變成值
2. 計算後保留公式
[attach]34052[/attach]

作者: samwang 時間: 2021-9-23 07:31

回復 1# PJChen

請測試看看，謝謝

Sub test()
Dim d, R%
d = Sheets("VBA").[Af2]
R = [北區!a65536].End(3).Row
With [北區!k3].Resize(R - 2)
.Formula = "=K2+G3-F3-H3-I3+J3"
'.Value = .Value '轉為值
End With
End Sub

作者: PJChen 時間: 2021-9-23 19:34

回復 2# samwang

您好,
測試沒問題,另外想請教
同一個檔案
C欄"供應商"分為大 & 美
從第3列開始,C欄<>美,則整列刪除
這是要單獨的程式....

作者: PJChen 時間: 2021-9-23 21:05

回復 2# samwang

另外,再請教

1) 為什麼程式,它能自動找到>=d的日期,進行計算呢?
d = Sheets("VBA").[Af2]

2) A欄,要取B欄的年月,YYYY..M
原先的寫法是
xR.Offset(, -1) = Year(xR) & ".." & Month(xR)
我套用現在新的程式,改為
.Formula = "=Format([b3], "YYYY") & ".." & Format([b3], "M")"
但無法帶出我要的值,請問要如何改這段？

作者: PJChen 時間: 2021-9-23 21:40

回復 2# samwang

您好,
我將K欄清空,反覆執行程式,發現它不會判別B欄>=d
d = Sheets("VBA").[Af2]
工作表日期是從6/1開始,假設當d=6/19
它無法找到B欄>=d的日期,再進行計算
而是永遠都從K3開始計算

作者: samwang 時間: 2021-9-24 07:57

回復 4# PJChen

1) 為什麼程式,它能自動找到>=d的日期,進行計算呢?
>> 不好意思，我沒注意到有這個條件，已更新如下，請測試看看，謝謝

2) A欄,要取B欄的年月,YYYY..M
>> 已更新如下，謝謝

Sub test()
Dim Arr, d, R%
d = Sheets("VBA").[Af2]
R = [北區!b65536].End(3).Row
With Sheets("北區").Range("a1:k" & R)
Arr = .Value
For i = 3 To UBound(Arr)
      .Cells(i, "a").Formula = "=YEAR(RC[1]) & "".."" & MONTH(RC[1])"
      If Arr(i, 2) >= d Then
         .Cells(i, "k").Formula = "=R[-1]C+RC[-4]-RC[-5]-RC[-3]-RC[-2]+RC[-1] "
      End If
Next
'.Value = .Value '轉為值
End With
End Sub

作者: samwang 時間: 2021-9-24 10:31

回復 samwang

您好,
測試沒問題,另外想請教
同一個檔案
C欄"供應商"分為大 & 美
從第3列開始,C欄美 ...
PJChen 發表於 2021-9-23 19:34

請測試看看，謝謝
Sub 刪除列()
Dim Arr, i&, j%, n%
With Sheets("北區")
With Range(.[k3], .[a65536].End(3))
      Arr = .Value
      For i = 1 To UBound(Arr)
         If Arr(i, 3) <> "美" Then GoTo 99
         n = n + 1
         For j = 1 To UBound(Arr, 2)
            Arr(n, j) = Arr(i, j)
         Next
99:    Next
      .Clear
End With
With Range("a3").Resize(n, UBound(Arr, 2))
      .Value = Arr
      .Borders(xlBottom).Weight = xlHairline
End With
End With
End Sub

作者: samwang 時間: 2021-9-24 10:45

回復 samwang

您好,
測試沒問題,另外想請教
同一個檔案
C欄"供應商"分為大 & 美
從第3列開始,C欄美 ...
PJChen 發表於 2021-9-23 19:34

提供第2種刪除列方式，請測試看看，謝謝

Sub 刪除列2()
Dim xR As Range, xU As Range
For Each xR In Range("c3:c" & [c65536].End(3).Row).Rows
If IsError(Application.Match("美", xR, 0)) Then
If xU Is Nothing Then Set xU = xR Else Set xU = Union(xR, xU)
End If
Next
If Not xU Is Nothing Then xU.EntireRow.Delete
End Sub

作者: PJChen 時間: 2021-9-24 20:32

回復 6# samwang

我之前的這種寫法,要修改的時候,就得一直算儲存格,讓我頭昏@@
xR.Offset(, 9) = xR.Offset(-1, 9) + xR.Offset(, 5) - xR.Offset(, 4) - xR.Offset(, 6) - xR.Offset(, 7) + xR.Offset(, 8)
請問除了"RC"的寫法,還有其它方式嗎?

作者: samwang 時間: 2021-9-25 09:53

回復 9# PJChen

請測試看看，謝謝

Sub test()
Dim Arr, d, R%
d = Sheets("VBA").[Af2]
R = [北區!b65536].End(3).Row
With Sheets("北區").Range("a1:k" & R)
With [a3].Resize(R - 2)
.Formula = "=YEAR(B3) & "".."" & MONTH(B3)"
End With
.Value = .Value '轉為值
Arr = .Value
For i = 3 To UBound(Arr)
      If Arr(i, 2) >= d Then
         .Cells(i, "k").Formula = "=k" & i - 1 & "+G" & i & "-F" & i & "-H" & i & "-I" & i & "+j" & i
      End If
Next
'.Value = .Value '轉為值
End With
End Sub

作者: samwang 時間: 2021-9-25 16:14

本帖最後由 samwang 於 2021-9-25 16:16 編輯

回復 9# PJChen

不好意思，請教一下您既然要用VBA為什麼還在Excel寫公式?
後學覺得用VBA在excel寫公式怪怪的，
直接在excel寫入公式，這樣不就好了嗎?

作者: samwang 時間: 2021-9-25 18:34

回復 3# PJChen

同一個檔案
C欄"供應商"分為大 & 美
從第3列開始,C欄<>美,則整列刪除
這是要單獨的程式....
>> 請問#7、#8可以用嗎?

作者: PJChen 時間: 2021-9-25 21:01

本帖最後由 PJChen 於 2021-9-25 21:11 編輯

回復 11# samwang
您是指K3=K2+G3-F3-H3-I3+J3的公式嗎?
這是為了讓回覆者知道要如何計算
如果是指這個的話,因為我不會其他寫法,用了一段時間後,又要想學其他方式,
For Each xR In Range([B3], [b65535].End(3))
If xR >= d Then 'k+g-f-h-i+j
xR.Offset(, 9) = xR.Offset(-1, 9) + xR.Offset(, 5) - xR.Offset(, 4) - xR.Offset(, 6) - xR.Offset(, 7) + xR.Offset(, 8)
End If
Next
我最想學的是陣列方式,所以求教會寫的人
我常看准大的程式,但我資質不好,一直沒學會,
現在這個檔,每一欄計算,我都使用單獨的程式,

像前面的問題
A欄,要取B欄的年月,YYYY..M
我原先也是單獨的寫法,但我沒想到你把二個需求併在一起了

我想把這個檔,每個需要計算的欄位,都轉換為陣列寫法,
因為只寫一欄的計算比較沒那麼複雜,
希望看別人的程式後,可以學得一招半式！

我再自行修改,遇到改不出來再提問,
我不太清楚是否每種需求都可以用陣列...
這只是我心裡想的！

作者: PJChen 時間: 2021-9-25 21:20

回復 12# samwang

這二個程式執行後
都正確！

作者: PJChen 時間: 2021-9-25 21:45

回復 10# samwang

#6
.Cells(i, "a").Formula = "=YEAR(RC[1]) & "".."" & MONTH(RC[1])"
這段程式,都只能從第3列往下寫

#10
.Formula = "=YEAR(B3) & "".."" & MONTH(B3)"
這段程式,無法截取B欄資料,將YYYY..M填入A欄

作者: samwang 時間: 2021-9-26 06:37

回復 15# PJChen

#10
  .Formula = "=YEAR(B3) & "".."" & MONTH(B3)"
這段程式,無法截取B欄資料,將YYYY..M填入A欄
>> With [a3].Resize(R - 2)
.Formula = "=YEAR(B3) & "".."" & MONTH(B3)"
End With
.Value = .Value '轉為值
這功能正常，這是將B欄資料沒經過條件轉為 "2021..6 "
如過您的需求是要經過日期比較，請自行將 .Cells(i, "a").Formula = "=YEAR(RC[1]) & "".."" & MONTH(RC[1])"
移到if 底下
Sub test()
Dim Arr, d, R%
d = Sheets("VBA").[Af2]
R = [北區!b65536].End(3).Row
With Sheets("北區").Range("a1:k" & R)
' With [a3].Resize(R - 2)
' .Formula = "=YEAR(B3) & "".."" & MONTH(B3)"
' End With
' .Value = .Value '轉為值
Arr = .Value
For i = 3 To UBound(Arr)
      If Arr(i, 2) >= d Then
         .Cells(i, "a").Formula = "=YEAR(RC[1]) & "".."" & MONTH(RC[1])"
         .Cells(i, "k").Formula = "=k" & i - 1 & "+G" & i & "-F" & i & "-H" & i & "-I" & i & "+j" & i
      End If
Next
'.Value = .Value '轉為值
End With
End Sub
請在測試看看，謝謝

作者: samwang 時間: 2021-9-26 06:38

本帖最後由 samwang 於 2021-9-26 06:39 編輯

回復 15# PJChen

#10
  .Formula = "=YEAR(B3) & "".."" & MONTH(B3)"
這段程式,無法截取B欄資料,將YYYY..M填入A欄
>> With [a3].Resize(R - 2)
.Formula = "=YEAR(B3) & "".."" & MONTH(B3)"
End With
.Value = .Value '轉為值
這功能正常，這是將B欄資料沒經過條件轉為 "2021..6 "

如過您的需求是要經過日期比較，請自行將 .Cells(i, "a").Formula = "=YEAR(RC[1]) & "".."" & MONTH(RC[1])"
移到if 底下如下
Sub test()
Dim Arr, d, R%
d = Sheets("VBA").[Af2]
R = [北區!b65536].End(3).Row
With Sheets("北區").Range("a1:k" & R)
' With [a3].Resize(R - 2)
' .Formula = "=YEAR(B3) & "".."" & MONTH(B3)"
' End With
' .Value = .Value '轉為值
Arr = .Value
For i = 3 To UBound(Arr)
      If Arr(i, 2) >= d Then
         .Cells(i, "a").Formula = "=YEAR(RC[1]) & "".."" & MONTH(RC[1])"
         .Cells(i, "k").Formula = "=k" & i - 1 & "+G" & i & "-F" & i & "-H" & i & "-I" & i & "+j" & i
      End If
Next
'.Value = .Value '轉為值
End With
End Sub
請在測試看看，謝謝

作者: PJChen 時間: 2021-9-26 19:40

回復 17# samwang
測試沒問題了！

再請問同一檔案,另一段程式 [attach]34068[/attach]
E欄要填入單號(連結)T&S&R
但R欄=""時,則E欄="無交貨"
請問要如何改這段程式?
      If Arr(i, 2) >= d And Arr(i, "r") = "" Then 'Arr(i, 2),第2欄是日期,R欄無單號
         .Cells(i, "e").Formula = "無交貨"
      Else
         .Cells(i, "e").Formula = "=T&S&R"
      End If
Next

作者: PJChen 時間: 2021-9-26 20:58

回復 17# samwang

另外一個U欄程式,紅字這一段,日期+1的寫法不能用,請問如何讓日期+1
例如:u3=8/3,則+1=8/4
For i = 3 To UBound(Arr)
      If Arr(i, 2) >= d And Arr(i, 4) <> "中和" Or Arr(i, 4) <> "內湖" And Arr(i, 4) <> "汐止" Then 'i=列
         .Cells(i, "u").Formula = "=Arr(i, 2)" + 1
      ElseIf Arr(i, 2) >= d And Arr(i, 4) = "中和" Or Arr(i, 4) = "內湖" And Arr(i, 4) = "汐止" Then
         .Cells(i, "u").Formula = "Arr(i, 2)"
      End If
Next

作者: samwang 時間: 2021-9-27 07:45

回復 18# PJChen

E欄要填入單號(連結)T&S&R
但R欄=""時,則E欄="無交貨"
請問要如何改這段程式?
>> 依據您的程式做修改如下
      If Arr(i, 2) >= d And Arr(i, 18) = "" Then 'Arr(i, 2),第2欄是日期,R欄無單號
          .Cells(i, "e") = "無交貨"
      Else
           .Cells(i, "e").Formula = "=T" & i & " & S" & i & "& R" & i & ""
      End If

但是依據您的描述，後學覺得條件可以拆成2段if 比較好，謝謝
  If Arr(i, 2) >= d And Arr(i, 18) = "" Then 'Arr(i, 2),第2欄是日期,R欄無單號
      .Cells(i, "e") = "無交貨"
end if
If Arr(i, 2) >= d And Arr(i, 18) <> "" Then
      .Cells(i, "e").Formula = "=T" & i & " & S" & i & "& R" & i & ""
end if

作者: samwang 時間: 2021-9-27 08:05

本帖最後由 samwang 於 2021-9-27 08:07 編輯

回復 19# PJChen

另外一個U欄程式,紅字這一段,日期+1的寫法不能用,請問如何讓日期+1
      If Arr(i, 2) >= d And Arr(i, 4) <> "中和" Or Arr(i, 4) <> "內湖" And Arr(i, 4) <> "汐止" Then 'i=列
         .Cells(i, "u").Formula = "=B" & i & " +1 "
      ElseIf Arr(i, 2) >= d And Arr(i, 4) = "中和" Or Arr(i, 4) = "內湖" And Arr(i, 4) = "汐止" Then
         .Cells(i, "u").Formula = "=B" & i & ""
      End If

後學也是第一次用這種寫法(VBA在excel寫公式)，
寫了這幾次下來好像有點規則，只要遇到變數i " &   i & " 然後 & 其它

作者: PJChen 時間: 2021-9-27 12:38

回復 21# samwang

感謝您,
U & E欄的問題都解決了,
但發現另一個問題,因為每一個欄都有一個別的程式,
但只要執行了 .Value = .Value
就會干擾到其他欄位,也都變成值,
請問如何使程式之間不要互相干擾,
這樣需要保留公式的,就不會變成值！
~~~~~~~~~
另外,原來是用函數計算派板-交板差異,請問這個有辧法開為程式嗎? V欄的程式也是要單獨一個哦...
V3=IF(COUNTIFS(北區!$B$2:$B3,北區!$B3,北區!$D$2:$D3,北區!$D3)=1,SUMIFS(北區!$W:$W,北區!$B:$B,北區!$B3,北區!$D:$D,北區!$D3)-SUMIFS(北區!$F:$F,北區!$B:$B,北區!$U3,北區!$D:$D,北區!$D3),0)

作者: samwang 時間: 2021-9-27 13:00

回復 22# PJChen

但只要執行了 .Value = .Value
就會干擾到其他欄位,也都變成值,
>> 改為單獨欄轉為值
Range("K3:K" & R).Value = Range("K3:K" & R).Value 'K欄轉為值

作者: samwang 時間: 2021-9-27 14:06

回復 22# PJChen

另外,原來是用函數計算派板-交板差異,請問這個有辧法開為程式嗎? V欄的程式也是要單獨一個哦...
V3=IF(COUNTIFS(北區!$B$2:$B3,北區!$B3,北區!$D$2:$D3,北區!$D3)=1,SUMIFS(北區!$W:$W,北區!$B:$B,北區!$B3,北區!$D:$D,北區!$D3)-SUMIFS(北區!$F:$F,北區!$B:$B,北區!$U3,北區!$D:$D,北區!$D3),0)
>> 這是要做什麼??不知道您實際需求是什麼?

作者: PJChen 時間: 2021-9-28 15:20

本帖最後由 PJChen 於 2021-9-28 15:27 編輯

回復 23# samwang

您好,
轉換值的部份沒問題了！
另一個同一系列檔案,一樣指定d = xS.[Af2]

中區資料是一個全年度性的,會一直增加至年底,
H欄要統計D欄每個月最後一個日期的月統計數量
也就是同一年同一月的出貨數,第一筆不一定1日開始,最後一筆也不一定是月底日
,請問這程式要怎麼寫？
[attach]34077[/attach]

作者: samwang 時間: 2021-9-28 18:02

回復 25# PJChen

H欄要統計D欄每個月最後一個日期的月統計數量
>> 如下，請測試看看，謝謝
Sub test()
Dim Arr, Brr, xD, i&, T$, T1$
Arr = Sheets("中區").Range("a3:k" & [中區!a65536].End(3).Row + 1)
ReDim Brr(1 To UBound(Arr), 1 To 1)
Set xD = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Arr)
If Not IsDate(Arr(i, 1)) Then GoTo 98
T = Month(Arr(i, 1)): T1 = Month(Arr(i + 1, 1))
If xD.Exists(T) Then
      If T <> T1 Then
         xD(Arr(i, 1) & "_" & Arr(i, 3)) = Val(xD(T)) + Val(Arr(i, 4))
      Else
         xD(T) = Val(xD(T)) + Val(Arr(i, 4))
      End If
Else
      xD(T) = Val(Arr(i, 4))
End If
98: Next
For Each ky In xD.keys
For i = 1 To UBound(Arr)
      Brr(i, 1) = xD(Arr(i, 1) & "_" & Arr(i, 3))
Next
Next
Sheets("中區").[h3].Resize(UBound(Brr)) = Brr
End Sub

作者: PJChen 時間: 2021-9-28 19:48

回復 26# samwang

您好,
執行很快速,不過程式對我來說,複雜很多！能否幫我註解一下紅字用法?
另外這段程式"_",它代表什麼?
xD(Arr(i, 1) & "_" & Arr(i, 3)) = Val(xD(T)) + Val(Arr(i, 4))
Sub test()
Dim Arr, Brr, xD, i&, T$, T1$
Arr = Sheets("中區").Range("a3:k" & [中區!a65536].End(3).Row + 1)
ReDim Brr(1 To UBound(Arr), 1 To 1)
Set xD = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Arr)
If Not IsDate(Arr(i, 1)) Then GoTo 98
T = Month(Arr(i, 1)): T1 = Month(Arr(i + 1, 1))
If xD.Exists(T) Then
      If T <> T1 Then
          xD(Arr(i, 1) & "_" & Arr(i, 3)) = Val(xD(T)) + Val(Arr(i, 4))
      Else
         xD(T) = Val(xD(T)) + Val(Arr(i, 4))
      End If
Else
      xD(T) = Val(Arr(i, 4))
End If
98: Next
For Each ky In xD.keys
For i = 1 To UBound(Arr)
      Brr(i, 1) = xD(Arr(i, 1) & "_" & Arr(i, 3))
Next
Next
Sheets("中區").[h3].Resize(UBound(Brr)) = Brr
End Sub

作者: samwang 時間: 2021-9-29 07:58

回復 27# PJChen

能否幫我註解一下紅字用法? >>註解寫得不好、詞不達意，請見諒，謝謝

Sub test()
Dim Arr, Brr, xD, i&, T$, T1$
Arr = Sheets("中區").Range("a3:k" & [中區!a65536].End(3).Row + 1) '資料裝入陣列
ReDim Brr(1 To UBound(Arr), 1 To 1) '創空的陣列用來裝答案
Set xD = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Arr)
If Not IsDate(Arr(i, 1)) Then GoTo 98 '不是日期離開
T = Month(Arr(i, 1)): T1 = Month(Arr(i + 1, 1))
If xD.Exists(T) Then '是否A欄月份有在字典
      If T <> T1 Then '自己與下一列日期的月份比較
         '紀錄當月最後一筆的交板數量累加，key:最後日期_採購單號，避免最後一天有多筆
         xD(Arr(i, 1) & "_" & Arr(i, 3)) = Val(xD(T)) + Val(Arr(i, 4))
      Else
         xD(T) = Val(xD(T)) + Val(Arr(i, 4)) '同月份交板數量累加
      End If
Else
      xD(T) = Val(Arr(i, 4)) '交板數量裝入字典
End If
98: Next
For Each ky In xD.keys  '字典keys循環
For i = 1 To UBound(Arr)
      Brr(i, 1) = xD(Arr(i, 1) & "_" & Arr(i, 3)) '字典key:最後日期_採購單號，裝入答案陣列
Next
Next
Sheets("中區").[h3].Resize(UBound(Brr)) = Brr  '顯示答案
End Sub

作者: PJChen 時間: 2021-10-4 21:37

回復 28# samwang

您好,
請幫我看下程式
資料有多年度時,只有第一年計算正確,其餘合計會出錯...
[attach]34132[/attach]

作者: samwang 時間: 2021-10-5 07:31

回復 29# PJChen

資料有多年度時,只有第一年計算正確,其餘合計會出錯...
>> 更改如下，請測試看看，謝謝。
T = Year(Arr(i, 1)) & "|" & Month(Arr(i, 1)): T1 = Year(Arr(i, 1)) & "|" & Month(Arr(i + 1, 1))

作者: PJChen 時間: 2021-10-5 21:11

回復 30# samwang
您好,
程式更改後,仍會有錯誤,我將它篩選出來,
再麻煩幫忙看下！
感謝
[attach]34161[/attach]

作者: samwang 時間: 2021-10-6 07:27

回復 31# PJChen

多餘的統計問題
>> 更新如下紅字，請再測試看看，謝謝。
For Each ky In xD.keys
For i = 1 To UBound(Arr)
      If i < UBound(Arr) Then
         If Arr(i, 1) & "_" & Arr(i, 3) = Arr(i, 1) & "_" & Arr(i + 1, 3) Then GoTo 99
      End If
      Brr(i, 1) = xD(Arr(i, 1) & "_" & Arr(i, 3))
99: Next
Next

作者: PJChen 時間: 2021-10-6 13:55

本帖最後由 PJChen 於 2021-10-6 13:59 編輯

回復 32# samwang
謝謝，我再試試

作者: PJChen 時間: 2021-10-6 20:06

回復 32# samwang

您好,

經測試,最末一列單號空白時,無法統計數量
附上測試結果 [attach]34164[/attach]

作者: PJChen 時間: 2021-10-6 22:12

本帖最後由 PJChen 於 2021-10-6 22:20 編輯

回復 32# samwang

補充資料的規則:

1) A欄每月第一筆日期,不一定1日開始
2) A欄每月最後一筆也不一定是月底日,只要是每月的最後出現的日期就進行統計
3) 要把年度也考量進去,因為資料會不斷增加,不會只有一個年度
4) C欄的單號,會有同一日期,同一單號重複數次,我想程式中應該不用加上C欄的判別,因為單號與統計無關

我將程式改為以下,可否幫我看下,這樣會有bug嗎?
Dim Arr, Brr, xD, i&, T$, T1$
Arr = Sheets("中區").Range("a3:k" & [中區!a65536].End(3).Row + 1)
ReDim Brr(1 To UBound(Arr), 1 To 1)
Set xD = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Arr)
If Not IsDate(Arr(i, 1)) Then GoTo 98
T = Year(Arr(i, 1)) & "|" & Month(Arr(i, 1)): T1 = Year(Arr(i, 1)) & "|" & Month(Arr(i + 1, 1))

If xD.Exists(T) Then
      If T <> T1 Then
         xD(Arr(i, 1)) = Val(xD(T)) + Val(Arr(i, 4))
      Else
         xD(T) = Val(xD(T)) + Val(Arr(i, 4))
      End If
Else
      xD(T) = Val(Arr(i, 4))
End If
98: Next
'--------
For Each ky In xD.keys
For i = 1 To UBound(Arr)
      If i < UBound(Arr) Then
         If Arr(i, 1) = Arr(i + 1, 1) Then GoTo 99
      End If
      Brr(i, 1) = xD(Arr(i, 1))
99: Next
Next
Sheets("中區").[h3].Resize(UBound(Brr)) = Brr
End Sub

作者: samwang 時間: 2021-10-7 07:44

回復 35# PJChen

1) A欄每月第一筆日期,不一定1日開始
2) A欄每月最後一筆也不一定是月底日,只要是每月的最後出現的日期就進行統計
3) 要把年度也考量進去,因為資料會不斷增加,不會只有一個年度
4) C欄的單號,會有同一日期,同一單號重複數次,我想程式中應該不用加上C欄的判別,因為單號與統計無關
>> 您真的很用心把所有規則條件列出，35#有小問題我修改後如下，請再測試看看，謝謝
Sub test2()
Dim Arr, Brr, xD, i&, T$, T1$
Arr = Sheets("中區").Range("a3:k" & [中區!a65536].End(3).Row + 1)
ReDim Brr(1 To UBound(Arr), 1 To 1)
Set xD = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Arr)
If Not IsDate(Arr(i, 1)) Then GoTo 98
T = Year(Arr(i, 1)) & "|" & Month(Arr(i, 1)): T1 = Year(Arr(i, 1)) & "|" & Month(Arr(i + 1, 1))
If xD.Exists(T) Then
      If T <> T1 Then
         xD(Arr(i, 1)) = Val(xD(T)) + Val(Arr(i, 4))
      Else
         xD(T) = Val(xD(T)) + Val(Arr(i, 4))
      End If
Else
      xD(T) = Val(Arr(i, 4))
End If
98: Next
For Each ky In xD.keys
For i = 1 To UBound(Arr)
      If Not IsDate(Arr(i, 1)) Then GoTo 99
      T = Year(Arr(i, 1)) & "|" & Month(Arr(i, 1)): T1 = Year(Arr(i, 1)) & "|" & Month(Arr(i + 1, 1))
      If T <> T1 Then Brr(i, 1) = xD(Arr(i, 1))
99: Next
Next
Sheets("中區").[h3].Resize(UBound(Brr)) = Brr
End Sub

作者: PJChen 時間: 2021-11-2 22:08

回復 8# samwang

Sam
請問以下程式,我需要改為,符合2個條件,則整列刪除,請問要怎麼修改?
1) B欄>=[af1]
2) C欄<>"美"
[attach]34335[/attach]

Sub 刪除列2()
Dim xR As Range, xU As Range
For Each xR In Range("c3:c" & [c65536].End(3).Row).Rows
If IsError(Application.Match("美", xR, 0)) Then
If xU Is Nothing Then Set xU = xR Else Set xU = Union(xR, xU)
End If
Next
If Not xU Is Nothing Then xU.EntireRow.Delete
End Sub

複製代碼

作者: singo1232001 時間: 2021-11-3 02:59

本帖最後由 singo1232001 於 2021-11-3 03:09 編輯

回復 37# PJChen

Sub 刪rows()
f = Columns("A:G").Find("*", , -4163, , 1, 2).Row
dt = [AF1]
Dim x1 As Range, x As Range
For i = 3 To f
If DateValue(Cells(i, 2)) >= DateValue(dt) And Cells(i, 3) <> "美" Then
   Set x = Rows(i)
   If x1 Is Nothing Then Set x1 = x
   If Not x1 Is Nothing Then Set x1 = Union(x1, x)
End If
Next
If Not x1 Is Nothing Then x1.Delete
End Sub

另外補充之前提到的問題建議可讓過程與程式乾淨簡潔
1.建議用兩個日期判斷起始與結束當前只有一個
2.原始檔案不建議做任何修改建議vba產生的所有步驟(新修刪改) 將資料複製處理放置到一個新增的工作表做處理(至少有原始檔案避免操作錯誤無法倒回資料初始狀態,而且還可以做前後比對效率提升)
3.原始資料(北區)不建議放公式但新增的工作表可以放
VBA也會好寫很多

作者: samwang 時間: 2021-11-3 07:36

回復 37# PJChen

Sub 刪除列()
Dim xR As Range, xU As Range
For Each xR In Range("c3:c" & [c65536].End(3).Row).Rows
If xR = "美" Then GoTo 99
If xR.Offset(, -1) < [AF1] Then GoTo 99
Set xC = xR
If xU Is Nothing Then Set xU = xR Else Set xU = Union(xR, xU)
99: Next
If Not xU Is Nothing Then xU.EntireRow.Delete
End Sub

作者: PJChen 時間: 2021-11-3 19:53

回復 39# samwang

回復 38# singo1232001

感謝二位
程式都可以執行

作者: PJChen 時間: 2021-11-4 21:46

回復 39# samwang
Sam 晚上好,
我想依singo1232001的建議,設定日期區間(有時會用到),
設定區間2021/9/18(含)~2021/9/29(含)
符合條件則刪除<>"美"
If xR.Offset(, -1) < [AF1] And xR.Offset(, -1) < [AF2] Then GoTo 99
但2021/9/29(含)的設定無效,
刪除的是9/18之後的全部日期
請幫忙看下程式 ~~感謝~~
[attach]34344[/attach]

作者: samwang 時間: 2021-11-5 07:54

回復 41# PJChen

設定區間2021/9/18(含)~2021/9/29(含)

If xR.Offset(, -1) > [AF1] And xR.Offset(, -1) < [AF2] Then GoTo 99

作者: 准提部林 時間: 2021-11-7 09:52

做個較完整+防呆的方法:
Sub 刪除列()
Dim D(2) As Date, K%, MS$, xR As Range, xU As Range, N&
If IsDate([AF1]) Then D(1) = [AF1]: K = 1
If IsDate([AF2]) Then D(2) = [AF2]: K = K + 2
If K = 0 Then MsgBox "※未指定刪除日期! ": Exit Sub
If K = 1 Then D(2) = D(1): MS = D(1) & " 之後的資料"
If K = 2 Then D(1) = D(2): MS = D(2) & " 之前的資料"
If K = 3 Then
If D(2) < D(1) Then D(0) = D(1): D(1) = D(2): D(2) = D(0)
MS = D(1) & " 至 " & D(2) & " 之間的資料"
If D(1) = D(2) Then MS = D(1) & " 當天的資料"
End If
If MsgBox("※確定要刪除 " & MS & "？  ", 1 + 32 + 256) = vbCancel Then Exit Sub
'---------------------------------------------
For Each xR In Range([c3], [c65536].End(3))
If xR = "美" Or IsDate(xR(1, 0)) = False Then GoTo 99
D(0) = xR(1, 0)
If D(0) < D(1) Or D(0) > D(2) Then GoTo 99
N = N + 1
If N = 1 Then Set xU = xR Else Set xU = Union(xR, xU)
99: Next
If N = 0 Then MsgBox "※執行完畢! 找不到符合的資料!  ": Exit Sub
xU.Select
If MsgBox("※執行完畢! 共找到 " & N & " 筆符合資料，是否要刪除？  ", 4 + 32 + 256) = vbYes Then xU.EntireRow.Delete
End Sub

附件:
[attach]34356[/attach]

'==================================

作者: PJChen 時間: 2021-11-8 17:16

回復 43# 准提部林
准大好,
感謝^^
執行OK

回復 42# samwang
If xR = "美" Then GoTo 99
If xR.Offset(, -1) > [AF1] And xR.Offset(, -1) < [AF2] Then GoTo 99'這行的寫法,會導致執行結果錯誤
我一直測試各種組合,後來改為以下,則結果正確

For Each xR In Range("c3:c" & [c65536].End(3).Row).Rows
If xR = "美" Then GoTo 99
If xR.Offset(, -1) < [AF1] Then GoTo 99
If xR.Offset(, -1) > [AF2] Then GoTo 99
Set xC = xR
If xU Is Nothing Then Set xU = xR Else Set xU = Union(xR, xU)
99: Next
If Not xU Is Nothing Then xU.EntireRow.Delete

複製代碼

作者: samwang 時間: 2021-11-9 08:09

回復 44# PJChen

不好意思，太粗心大意沒有注意到問題，也可改為如下，謝謝

If xR.Offset(, -1) < [AF1] Or xR.Offset(, -1) > [AF2] Then GoTo 99

作者: PJChen 時間: 2022-1-4 22:45

回復 36# samwang

Sam您好,
我將統計改為I欄,又發現類似問題,
上回是最末一列單號空白時,無法統計數量
這次是最末一列,無法統計數量
[attach]34567[/attach]

Sub test()
Dim Arr, Brr, xD, i&, T$, T1$
Arr = Sheets("南區").Range("a3:k" & [中區!a65536].End(3).Row + 1)
ReDim Brr(1 To UBound(Arr), 1 To 1)
Set xD = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Arr)
If Not IsDate(Arr(i, 1)) Then GoTo 98
T = Year(Arr(i, 1)) & "|" & Month(Arr(i, 1)): T1 = Year(Arr(i, 1)) & "|" & Month(Arr(i + 1, 1))
If xD.Exists(T) Then
If T <> T1 Then
xD(Arr(i, 1)) = Val(xD(T)) + Val(Arr(i, 4))
Else
xD(T) = Val(xD(T)) + Val(Arr(i, 4))
End If
Else
xD(T) = Val(Arr(i, 4))
End If
98: Next
For Each ky In xD.keys
For i = 1 To UBound(Arr)
If Not IsDate(Arr(i, 1)) Then GoTo 99
T = Year(Arr(i, 1)) & "|" & Month(Arr(i, 1)): T1 = Year(Arr(i, 1)) & "|" & Month(Arr(i + 1, 1))
If T <> T1 Then Brr(i, 1) = xD(Arr(i, 1))
99: Next
Next
Sheets("南區").[i3].Resize(UBound(Brr)) = Brr
End Sub

複製代碼

作者: samwang 時間: 2022-1-5 07:41

回復 46# PJChen

請再測試看看，謝謝

Sub test()
Dim Arr, Brr, xD, i&, T$, T1$
Arr = Sheets("南區").Range("a3:k" & [南區!a65536].End(3).Row)
ReDim Brr(1 To UBound(Arr), 1 To 1)
Set xD = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Arr)
If Not IsDate(Arr(i, 1)) Then GoTo 98
T = Year(Arr(i, 1)) & "|" & Month(Arr(i, 1))
If i < UBound(Arr) Then T1 = Year(Arr(i, 1)) & "|" & Month(Arr(i + 1, 1)) Else T1 = 0
If xD.Exists(T) Then
      If T <> T1 Then
         xD(Arr(i, 1)) = Val(xD(T)) + Val(Arr(i, 4))
         Brr(i, 1) = xD(Arr(i, 1))
      Else
         xD(T) = Val(xD(T)) + Val(Arr(i, 4))
      End If
Else
      xD(T) = Val(Arr(i, 4))
End If
98: Next
Sheets("南區").[i3].Resize(UBound(Brr)) = Brr
End Sub

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