PJChen

　暱稱: PJ

帖子: 913
主題: 150
精華: 0
積分: 1089
點名: 0
作業系統: win10
軟體版本: office 2019
閱讀權限: 50
性別: 女
註冊時間: 2011-8-28
最後登錄: 2023-7-19

論壇榮譽勳章論壇贊助勳章

1^# 跳轉到 » 正序看帖

打印

字體大小: tT

發表於 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. 計算後保留公式

核銷明細2021.rar (18.67 KB)

樓主熱帖

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2024-10-30

47^#

發表於 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

TOP

PJChen

　暱稱: PJ

大學生 Rank: 4

帖子: 913
主題: 150
精華: 0
積分: 1089
點名: 0
作業系統: win10
軟體版本: office 2019
閱讀權限: 50
性別: 女
註冊時間: 2011-8-28
最後登錄: 2023-7-19

論壇榮譽勳章論壇贊助勳章

46^#

發表於 2022-1-4 22:45 | 只看該作者

回復 36# samwang

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

中區_多年度.rar (87.81 KB)

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

複製代碼

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2024-10-30

45^#

發表於 2021-11-9 08:09 | 只看該作者

回復 44# PJChen

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

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

TOP

PJChen

　暱稱: PJ

大學生 Rank: 4

帖子: 913
主題: 150
精華: 0
積分: 1089
點名: 0
作業系統: win10
軟體版本: office 2019
閱讀權限: 50
性別: 女
註冊時間: 2011-8-28
最後登錄: 2023-7-19

論壇榮譽勳章論壇贊助勳章

44^#

發表於 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

複製代碼

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2834
主題: 10
精華: 0
積分: 2890
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-25

43^#

發表於 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

附件:

刪除列_3個條件_起迄日期-v1.rar (21.29 KB)

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

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2024-10-30

42^#

發表於 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

TOP

PJChen

　暱稱: PJ

大學生 Rank: 4

帖子: 913
主題: 150
精華: 0
積分: 1089
點名: 0
作業系統: win10
軟體版本: office 2019
閱讀權限: 50
性別: 女
註冊時間: 2011-8-28
最後登錄: 2023-7-19

論壇榮譽勳章論壇贊助勳章

41^#

發表於 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之後的全部日期
請幫忙看下程式 ~~感謝~~

整列刪除_3個條件_起迄日期.rar (18.34 KB)

TOP

PJChen

　暱稱: PJ

大學生 Rank: 4

帖子: 913
主題: 150
精華: 0
積分: 1089
點名: 0
作業系統: win10
軟體版本: office 2019
閱讀權限: 50
性別: 女
註冊時間: 2011-8-28
最後登錄: 2023-7-19

論壇榮譽勳章論壇贊助勳章

40^#

發表於 2021-11-3 19:53 | 只看該作者

回復 39# samwang

回復 38# singo1232001

感謝二位
程式都可以執行

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2024-10-30

39^#

發表於 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

TOP