Sub 找最大值并且復制到匯總作業表()
Dim rGetRange As Range
If Sheets(2).Range("B30") > Sheets(2).Range("B100") Then
Dim a1 As Integer, a2 As Integer, a3 As Integer
a1 = Sheets(1).Range("a2").Value
a2 = Sheets(1).Range("a3").Value
a3 = Sheets(1).Range("a4").Value
Dim r1 As Long, r2 As Long, r3 As Long, r4 As Long
arr_a = Array(a1, a2)
r1 = Sheets(2).Columns(1).Find(arr_a(0), , , xlWhole, xlByRows, xlPrevious).Row '1004
r2 = Sheets(2).Columns(1).Find(arr_a(1), , , xlWhole, xlByRows, xlPrevious).Row
Sheets(2).Activate
Set rng9 = Sheets(2).Range(Cells(r1, 122), Cells(r2, 122))
Set rGetRange = rng9.Find(Application.Max(rng9), , , , xlByRows, xlPrevious) '回傳nothing,出現問題的陳述句就是這句!!!!!!!!!!!!!!!!!!!!!!!!!!!
Set rGetRange = rng9.Find(Application.Max(rng9), , , , , xlPrevious) '回傳nothing
If Not rGetRange Is Nothing Then Rows(rGetRange).Font.ColorIndex = 4 'If Not rGetRange Is Nothing Then Rows(rGetRange.Row).Font.ColorIndex = 4
Set rng9 = Nothing
arr_b = Array(a2, a3)
r3 = Columns(1).Find(arr_b(0), , , xlWhole, xlByRows, xlPrevious).Row
r4 = Columns(1).Find(arr_b(1), , , xlWhole, xlByRows, xlPrevious).Row
Sheets(2).Activate
Set rng9 = Sheets(2).Range(Cells(r3, 122), Cells(r4, 122))
Set rGetRange = rng9.Find(Application.Max(rng9), , , , xlByRows, xlPrevious)
If Not rGetRange Is Nothing Then Rows(rGetRange).Font.ColorIndex = 4
Set rng9 = Nothing
Else
Dim a4 As Integer, a5 As Integer, a6 As Integer, a7 As Long
a4 = Sheets(2).Cells(3, 1).Value
a7 = Sheets(2).Range("A65536").End(xlUp).Value
a5 = Sheets(1).Cells(2, 1).Value
a6 = Sheets(1).Cells(3, 1).Value
Dim r5 As Long, r6 As Long, r7 As Long, r8 As Long, r9 As Long, r10 As Long
arr_c = Array(a4, a5)
r5 = Sheets(2).Columns(1).Find(arr_c(0), , , xlWhole, xlByRows, xlPrevious).Row
r6 = Sheets(2).Columns(1).Find(arr_c(1), , , xlWhole, xlByRows, xlPrevious).Row
Sheets(2).Activate
Set rng9 = Sheets(2).Range(Cells(r5, 122), Cells(r6, 122))
Set rGetRange = rng9.Find(Application.Max(rng9), , , , xlByRows, xlPrevious) '有時回傳nothing 有時不回傳但是值錯誤
If Not rGetRange Is Nothing Then Rows(rGetRange).Font.ColorIndex = 4
Set rng9 = Nothing
arr_d = Array(a5, a6)
r7 = Sheets(2).Columns(1).Find(arr_d(0), , , xlWhole, xlByRows, xlPrevious).Row
r8 = Sheets(2).Columns(1).Find(arr_d(1), , , xlWhole, xlByRows, xlPrevious).Row
Sheets(2).Activate
Set rng9 = Sheets(2).Range(Cells(r7, 122), Cells(r8, 122))
Set rGetRange = rng9.Find(Application.Max(rng9), , , , xlByRows, xlPrevious)
If Not rGetRange Is Nothing Then Rows(rGetRange).Font.ColorIndex = 4
Set rng9 = Nothing
arr_e = Array(a6, a7)
r9 = Sheets(2).Columns(1).Find(arr_e(0), , , , xlByRows, xlPrevious).Row
r10 = Sheets(2).Columns(1).Find(arr_e(1), , , , xlByRows, xlPrevious).Row
Sheets(2).Activate
Set rng9 = Sheets(2).Range(Cells(r9, 122), Cells(r10, 122))
Set rGetRange = rng9.Find(Application.Max(rng9), , , , xlByRows, xlPrevious)
If Not rGetRange Is Nothing Then Rows(rGetRange).Font.ColorIndex = 4
Set rng9 = Nothing
End If
Dim rng6 As Range 'copy
Dim rng5 As Range
Dim cel4 As Range
Dim n4 As Long
Dim b4%
Dim c4%
n4 = Application.WorksheetFunction.CountA(Sheets(2).Range("DR:DR")) '計算DR列有多少行
c4 = 7
Set rng6 = Sheets(2).Columns(122)
Set rng5 = rng6.Columns(122)
Sheets(1).Range("a7").Value = "MAX"
For b4 = 1 To n4 'bug
For Each cel4 In rng6.Rows(b4).Cells
If cel4.Characters(Start:=b4, Length:=1).Font.ColorIndex = 4 Then 'bug怎樣將字體顏色 改為 背景色 格式
c4 = c4 + 1
Sheets(2).Rows(b4).Copy Sheets(1).Range("a" & c4) 'Sheets(1).Range("A1").Copy Sheet10.rows(1)
Exit For
End If
Next
Next
End Sub
有問題的陳述句注釋已經標出(就是很多感嘆號的那句),程式可執行,未報錯,但是達不到我想要的效果,經過監視視窗發現,運行到Set rng9 = Sheets(2).Range(Cells(r1, 122), Cells(r2, 122)) 這句,rng9回傳了一個range,運行到 Set rGetRange = rng9.Find(Application.Max(rng9), , , , xlByRows, xlPrevious)這句,rgetrange回傳的卻是nothing. 另外監視視窗顯示max(rng9)運算式在背景關系中未定義。
即使執行到接下來的一個陳述句,rgetrange回傳的仍然是nothing。求解
uj5u.com熱心網友回復:
應該是 WorksheetFunction.Max() 而不是 Application.Max()還有你的代碼有變數未定義的錯誤,在整個代碼模塊的最開始加一行 Option Explicit
uj5u.com熱心網友回復:
謝謝回復,改過之后還是max(rng9)運算式在背景關系中未定義Option Explicit
Sub 找最大值并且復制到匯總作業表()
Dim rGetRange As Range
Dim rng9 As Range
'With Sheets(2)
If Sheets(2).Range("B30") > Sheets(2).Range("B100") Then
Dim a1 As Integer, a2 As Integer, a3 As Integer
Dim arr_a(1) As Integer
Dim arr_b(1) As Integer
a1 = Sheets(1).Range("a2").Value
a2 = Sheets(1).Range("a3").Value
a3 = Sheets(1).Range("a4").Value
Dim r1 As Long, r2 As Long, r3 As Long, r4 As Long '演算法問題
arr_a(0) = a1
arr_a(1) = a2
'Stop
r1 = Sheets(2).Columns(1).Find(arr_a(0), , , xlWhole, xlByRows, xlPrevious).Row '1004
r2 = Sheets(2).Columns(1).Find(arr_a(1), , , xlWhole, xlByRows, xlPrevious).Row
Sheets(2).Activate
Set rng9 = Sheets(2).Range(Cells(r1, 122), Cells(r2, 122))
Set rGetRange = rng9.Find(WorksheetFunction.Max(rng9), , , , xlByRows, xlPrevious)
If Not rGetRange Is Nothing Then Rows(rGetRange).Font.ColorIndex = 4 'If Not rGetRange Is Nothing Then Rows(rGetRange.Row).Font.ColorIndex = 4
Set rng9 = Nothing
'arr_b = Array(a2, a3)
arr_b(0) = a2
arr_b(1) = a3
r3 = Columns(1).Find(arr_b(0), , , xlWhole, xlByRows, xlPrevious).Row
r4 = Columns(1).Find(arr_b(1), , , xlWhole, xlByRows, xlPrevious).Row
Sheets(2).Activate
Set rng9 = Sheets(2).Range(Cells(r3, 122), Cells(r4, 122))
Set rGetRange = rng9.Find(WorksheetFunction.Max(rng9), , , , xlByRows, xlPrevious)
If Not rGetRange Is Nothing Then Rows(rGetRange).Font.ColorIndex = 4
Set rng9 = Nothing
Else
Dim arr_c(1) As Integer
Dim arr_d(1) As Integer
Dim arr_e(1) As Integer
Dim a4 As Integer, a5 As Integer, a6 As Integer, a7 As Integer
a4 = Sheets(2).Cells(3, 1).Value
a5 = Sheets(1).Cells(2, 1).Value
a6 = Sheets(1).Cells(3, 1).Value
a6 = Sheets(2).Range("dr65536").End(xlUp).Value
Dim r5 As Long, r6 As Long, r7 As Long, r8 As Long, r9 As Long, r10 As Long
'arr_c = Array(a4, a5)
arr_c(0) = a4
arr_c(1) = a5
r5 = Sheets(2).Columns(1).Find(arr_c(0), , , xlWhole, xlByRows, xlPrevious).Row
r6 = Sheets(2).Columns(1).Find(arr_c(1), , , xlWhole, xlByRows, xlPrevious).Row
Sheets(2).Activate
Set rng9 = Sheets(2).Range(Cells(r5, 122), Cells(r6, 122))
Set rGetRange = rng9.Find(WorksheetFunction.Max(rng9), , , , xlByRows, xlPrevious)
If Not rGetRange Is Nothing Then Rows(rGetRange).Font.ColorIndex = 4
Set rng9 = Nothing
'arr_d = Array(a5, a6)
arr_d(0) = a5
arr_d(1) = a6
r7 = Columns(1).Find(arr_d(0), , , xlWhole, xlByRows, xlPrevious).Row
r8 = Columns(1).Find(arr_d(1), , , xlWhole, xlByRows, xlPrevious).Row
Sheets(2).Activate
Set rng9 = Sheets(2).Range(Cells(r7, 122), Cells(r8, 122))
Set rGetRange = rng9.Find(WorksheetFunction.Max(rng9), , , , xlByRows, xlPrevious)
If Not rGetRange Is Nothing Then Rows(rGetRange).Font.ColorIndex = 4
Set rng9 = Nothing
'arr_e = Array(a6, a7)
arr_e(0) = a6
arr_e(0) = a7
r9 = Columns(1).Find(arr_e(0), , , , xlByRows, xlPrevious).Row
r10 = Columns(1).Find(arr_e(0), , , , xlByRows, xlPrevious).Row
Sheets(2).Activate
Set rng9 = Sheets(2).Range(Cells(r9, 122), Cells(r10, 122))
Set rGetRange = rng9.Find(WorksheetFunction.Max(rng9), , , , xlByRows, xlPrevious)
If Not rGetRange Is Nothing Then Rows(rGetRange).Font.ColorIndex = 4
Set rng9 = Nothing
End If
Dim rng6 As Range 'copy
Dim rng5 As Range
Dim cel4 As Range
Dim n4 As Long
Dim b4%
Dim c4%
n4 = Application.WorksheetFunction.CountA(Sheets(2).Range("DR:DR")) '計算DR列有多少行
c4 = 7
Set rng6 = Sheets(2).Columns(122)
Set rng5 = rng6.Columns(122)
Sheets(1).Range("a7").Value = "MAX"
For b4 = 1 To n4 'bug
For Each cel4 In rng6.Rows(b4).Cells
If cel4.Characters(Start:=b4, Length:=1).Font.ColorIndex = 4 Then 'bug怎樣將字體顏色 改為 背景色 格式
c4 = c4 + 1
Sheets(2).Rows(b4).Copy Sheets(1).Range("a" & c4) 'Sheets(1).Range("A1").Copy Sheet10.rows(1)
Exit For
End If
Next
Next
End Sub
uj5u.com熱心網友回復:
編譯沒問題啊。uj5u.com熱心網友回復:
這個程式應該是在幾個范圍內分別找到最大值,然后將最值所在的行復制到一個sheeet中但是程式運行的結果是找到了一個不相關的值,而且只復制一行
程式運行結果應該是2行或3行才對
所以我懷疑是找的程式寫錯了,但卻看不出問題在哪,程式運行也不報錯
Set rGetRange = rng9.Find(WorksheetFunction.Max(rng9), , , , xlByRows, xlPrevious)
uj5u.com熱心網友回復:
Option Explicit
Sub 找最大值并且復制到匯總作業表()
Dim rGetRange As Range
Dim rng9 As Range
'With Sheets(2)
If Sheets(2).Range("B30") > Sheets(2).Range("B100") Then
Dim a1 As Integer, a2 As Integer, a3 As Integer
Dim arr_a(1) As Integer
Dim arr_b(1) As Integer
a1 = Sheets(1).Range("a2").Value
a2 = Sheets(1).Range("a3").Value
a3 = Sheets(1).Range("a4").Value
Dim r1 As Long, r2 As Long, r3 As Long, r4 As Long '演算法問題
arr_a(0) = a1
arr_a(1) = a2
'Stop
r1 = Sheets(2).Columns(1).Find(arr_a(0), , , xlWhole, xlByRows, xlPrevious).Row '1004
r2 = Sheets(2).Columns(1).Find(arr_a(1), , , xlWhole, xlByRows, xlPrevious).Row
Sheets(2).Activate
Set rng9 = Sheets(2).Range(Cells(r1, 122), Cells(r2, 122))
Set rGetRange = rng9.Find(WorksheetFunction.Max(rng9), , , , xlByRows, xlPrevious)
If Not rGetRange Is Nothing Then Rows(rGetRange).Font.ColorIndex = 4 'If Not rGetRange Is Nothing Then Rows(rGetRange.Row).Font.ColorIndex = 4
Set rng9 = Nothing
'arr_b = Array(a2, a3)
arr_b(0) = a2
arr_b(1) = a3
r3 = Columns(1).Find(arr_b(0), , , xlWhole, xlByRows, xlPrevious).Row
r4 = Columns(1).Find(arr_b(1), , , xlWhole, xlByRows, xlPrevious).Row
Sheets(2).Activate
Set rng9 = Sheets(2).Range(Cells(r3, 122), Cells(r4, 122))
Set rGetRange = rng9.Find(WorksheetFunction.Max(rng9), , , , xlByRows, xlPrevious)
If Not rGetRange Is Nothing Then Rows(rGetRange).Font.ColorIndex = 4
Set rng9 = Nothing
' Dim rng3 As Range 'copy
' Dim rng4 As Range
'Dim cel3 As Range
' Dim b3%
' Dim c3%
' c = 1
' Set rng3 = Sheets(2).Columns(122)
' Set rng4 = rng3.Columns(122)
' Sheets(1).Range("a5").Value = "MAX"
' For b3 = 1 To n 'bug
' For Each cel3 In rng3.Rows(b).Cells
' If cel3.Characters(Start:=b, Length:=1).Font.ColorIndex = 4 Then 'bug怎樣將字體顏色 改為 背景色 格式
' c3 = c3 + 5
' Sheets(2).Rows(b).Copy Sheets(1).Range("a" & c) 'Sheets(1).Range("A1").Copy Sheet10.rows(1)
' Stop
' Exit For
' End If
' Next
' Next
Else
Dim arr_c(1) As Integer
Dim arr_d(1) As Integer
Dim arr_e(1) As Long
Dim a4 As Integer, a5 As Integer, a6 As Integer, a7 As Long
a4 = Sheets(2).Cells(3, 1).Value
a5 = Sheets(1).Cells(2, 1).Value
a6 = Sheets(1).Cells(3, 1).Value
a7 = Sheets(2).Range("a65536").End(xlUp).Value 'bug
Dim r5 As Long, r6 As Long, r7 As Long, r8 As Long, r9 As Long, r10 As Long
'arr_c = Array(a4, a5)
arr_c(0) = a4
arr_c(1) = a5
r5 = Sheets(2).Columns(1).Find(arr_c(0), , , xlWhole, xlByRows, xlPrevious).Row
r6 = Sheets(2).Columns(1).Find(arr_c(1), , , xlWhole, xlByRows, xlPrevious).Row
Sheets(2).Activate
Set rng9 = Sheets(2).Range(Cells(r5, 122), Cells(r6, 122))
Set rGetRange = rng9.Find(WorksheetFunction.Max(rng9), , , , xlByRows, xlPrevious)
If Not rGetRange Is Nothing Then Rows(rGetRange).Font.ColorIndex = 4
Set rng9 = Nothing
'arr_d = Array(a5, a6)
arr_d(0) = a5
arr_d(1) = a6
r7 = Columns(1).Find(arr_d(0), , , xlWhole, xlByRows, xlPrevious).Row
r8 = Columns(1).Find(arr_d(1), , , xlWhole, xlByRows, xlPrevious).Row
Sheets(2).Activate
Set rng9 = Sheets(2).Range(Cells(r7, 122), Cells(r8, 122))
Set rGetRange = rng9.Find(WorksheetFunction.Max(rng9), , , , xlByRows, xlPrevious)
If Not rGetRange Is Nothing Then Rows(rGetRange).Font.ColorIndex = 4
Set rng9 = Nothing
'arr_e = Array(a6, a7)
arr_e(0) = a6
arr_e(0) = a7
r9 = Columns(1).Find(arr_e(0), , , , xlByRows, xlPrevious).Row
r10 = Columns(1).Find(arr_e(0), , , , xlByRows, xlPrevious).Row
Sheets(2).Activate
Set rng9 = Sheets(2).Range(Cells(r9, 122), Cells(r10, 122))
Set rGetRange = rng9.Find(WorksheetFunction.Max(rng9), , , , xlByRows, xlPrevious)
If Not rGetRange Is Nothing Then Rows(rGetRange).Font.ColorIndex = 4
Set rng9 = Nothing
End If
Dim rng6 As Range 'copy
Dim rng5 As Range
Dim cel4 As Range
Dim n4 As Long
Dim b4%
Dim c4%
n4 = Application.WorksheetFunction.CountA(Sheets(2).Range("DR:DR")) '計算DR列有多少行
c4 = 7
Set rng6 = Sheets(2).Columns(122)
Set rng5 = rng6.Columns(122)
Sheets(1).Range("a7").Value = "MAX"
For b4 = 1 To n4 'bug
For Each cel4 In rng6.Rows(b4).Cells
If cel4.Characters(Start:=b4, Length:=1).Font.ColorIndex = 4 Then 'bug怎樣將字體顏色 改為 背景色 格式
c4 = c4 + 1
Sheets(2).Rows(b4).Copy Sheets(1).Range("a" & c4) 'Sheets(1).Range("A1").Copy Sheet10.rows(1)
Exit For
End If
Next
Next
End Sub
uj5u.com熱心網友回復:
改了一些小錯,當然程式還是有問題uj5u.com熱心網友回復:
這代碼眼緣不好。給一段資料實體,大家可能會給你一段簡潔高效的代碼.....
uj5u.com熱心網友回復:
發現bug了If Not rGetRange Is Nothing Then Rows(rGetRange).Font.ColorIndex = 4
這句不只會把字體顏色改為4號,而且會把rgetrange所在的范圍變為第四行
我寫這句的原意是想把rgetrange所在的行的字體顏色改為4號……
uj5u.com熱心網友回復:
注釋掉所有On Error Resume Next陳述句,在VB6 IDE中運行,出錯后點擊除錯,游標會停在出錯的那條陳述句處,此時可以在立即視窗中使用?變數名
或
?函式名(函式引數)
或
程序名(引數)
輔助除錯。
轉載請註明出處,本文鏈接:https://www.uj5u.com/gongcheng/62443.html
標籤:VBA
上一篇:VB.net怎么在類別庫中使用DataGridView控制元件
下一篇:VB6 資料整理請教
