大量資料計算

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

12^#

發表於 2021-10-8 07:25 | 只看該作者

回復 10# oak0723-1

您的公式的條件與描述條件不一樣如照片，請問哪個是正確?
另外請問上下限的定義是對的嗎? 舉例上限1001，下限1006，數字要對調吧? 正確上限1006、下限1001

11.PNG (56.29 KB)

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

13^#

發表於 2021-10-8 11:09 | 只看該作者

回復 10# oak0723-1

數值若在於上下限界內則為1,若低於下限或高於上限則顯示 0
如下，請測試看看，謝謝

Sub test()
Dim Arr, Drr, Brr(), Crr(), T, XMax, XMin
Tm = Timer
Arr = Range([資料庫!b6], [資料庫!b65536].End(3))
'Drr = Sheets("資料庫").Range("i6:ama" & UBound(Arr) + 5)
Drr = Sheets("資料庫").Range("i6:p" & UBound(Arr) + 5)
[比對!b6].Resize(UBound(Arr)) = Arr
ReDim Brr(1 To UBound(Arr), 1 To 8) '1 to 1000
ReDim Crr(1 To UBound(Arr), 1 To 1)
With Sheets("比對")
Arr = .Range("i3:p4")
For i = 1 To UBound(Drr)
      Crr(i, 1) = 0
      For j = 1 To UBound(Arr, 2)
         T = Drr(i, j): XMin = Arr(1, j): XMax = Arr(2, j)
         If XMin = "" Or T = "" Then Brr(i, j) = "": GoTo 99
         If T < XMin Or T > XMax Then
            Brr(i, j) = 0
         Else
               Brr(i, j) = 1: Crr(i, 1) = Crr(i, 1) + 1
         End If
99:    Next j
Next i
.Range("h6").Resize(UBound(Crr)) = Crr
.Range("i6").Resize(UBound(Brr), UBound(Brr, 2)) = Brr
End With
MsgBox Timer - Tm
End Sub

oak0723-1

中學生 Rank: 2

帖子: 222
主題: 56
精華: 0
積分: 285
點名: 0
作業系統: window
軟體版本: office2003
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2010-8-30
最後登錄: 2024-4-22

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

14^#

發表於 2021-10-8 18:16 | 只看該作者

回復 13# samwang
你好
測試一下發現有些問題
我增加資料列數和欄數
發現不能隨增減資料數變動比對結果
如附件說明

Image 143-1.jpg (135.45 KB)

1101005-比對&合計02-1.rar (119.05 KB)

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

15^#

發表於 2021-10-9 05:47 | 只看該作者

回復 14# oak0723-1

我增加資料列數和欄數
發現不能隨增減資料數變動比對結果
>> 已更新，請再測試看看，謝謝

Sub test()
Dim Arr, Drr, Brr(), Crr(), T, XMax, XMin, R%, C%
Tm = Timer
With Sheets("資料庫")
R = .[b6].End(4).Row
C = .Cells(5, Columns.Count).End(1).Column
Arr = .Range(.[b6], .Cells(R, 2))
Drr = .Range(.[i6], .Cells(R, C))
End With
With Sheets("比對")
.[b6].Resize(UBound(Arr)) = Arr
ReDim Brr(1 To UBound(Arr), 1 To UBound(Drr, 2))
ReDim Crr(1 To UBound(Arr), 1 To 1)
C = .Cells(3, Columns.Count).End(1).Column
Arr = .Range(.[i3], .Cells(4, C))
For i = 1 To UBound(Drr)
      Crr(i, 1) = 0
      For j = 1 To UBound(Arr, 2)
         T = Drr(i, j): XMin = Arr(1, j): XMax = Arr(2, j)
         If XMin = "" Or T = "" Then Brr(i, j) = "": GoTo 99
         If T < XMin Or T > XMax Then
            Brr(i, j) = 0
         Else
               Brr(i, j) = 1: Crr(i, 1) = Crr(i, 1) + 1
         End If
99:    Next j
Next i
.Range("h6").Resize(UBound(Crr)) = Crr
.Range("i6").Resize(UBound(Brr), UBound(Brr, 2)) = Brr
End With
MsgBox Timer - Tm
End Sub

oak0723-1

中學生 Rank: 2

帖子: 222
主題: 56
精華: 0
積分: 285
點名: 0
作業系統: window
軟體版本: office2003
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2010-8-30
最後登錄: 2024-4-22

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

16^#

發表於 2021-10-9 14:23 | 只看該作者

回復 15# samwang

你好
感謝你願熱心幫忙
目前測試執行發生"陣列索引超出範圍"的問題

Image 6.jpg (257.54 KB)

1101005-比對&合計02-1-1.rar (147.84 KB)

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

17^#

發表於 2021-10-10 12:44 | 只看該作者

回復 16# oak0723-1

目前測試執行發生"陣列索引超出範圍"的問題
>> 因為資料庫與比對的欄位不一致導致問題，已更新新增1列如下紅字，請再測試看看，謝謝

...
...
With Sheets("比對")
.[b6].Resize(UBound(Arr)) = Arr
ReDim Brr(1 To UBound(Arr), 1 To UBound(Drr, 2))
ReDim Crr(1 To UBound(Arr), 1 To 1)
C1 = .Cells(3, Columns.Count).End(1).Column
If C1 > C Then C = C Else C = C1
Arr = .Range(.[i3], .Cells(4, C))
For i = 1 To UBound(Drr)
...
...