PJChen

回復 30# samwang
您好,
程式更改後,仍會有錯誤,我將它篩選出來,
再麻煩幫忙看下！
感謝
中區_多年度new.rar (74.34 KB)

下載次數: 3

2021-10-5 21:11

samwang

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

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

PJChen

回復 32# samwang

您好,

經測試,最末一列單號空白時,無法統計數量
附上測試結果 中區_多年度.rar (74.6 KB)

下載次數: 2

2021-10-6 19:52

PJChen

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

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

回復 8# samwang

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

下載次數: 2

2021-11-2 22:08

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

複製代碼

singo1232001

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

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

回復 39# samwang

回復 38# singo1232001

感謝二位
程式都可以執行