|
下記のコードを追加してください
'先頭レコード
Private Sub CommandButton3_Click()
Dim sr As String
If FindMin(sr) Then
DataDisp sr
Else
Beep
End If
End Sub
'前のレコード
Private Sub CommandButton4_Click()
Dim sr As String
If Range("F2") = "" Then
CommandButton6_Click
Else
If IsNumeric(Sheets("T戦績").Range("CT9")) Then
CopyToSheetCheck Sheets("T戦績").Range("CT9"), sr
DataDisp sr
Else
Beep
End If
End If
End Sub
'次のレコード
Private Sub CommandButton5_Click()
Dim sr As String
If Range("F2") = "" Then
CommandButton3_Click
Else
If IsNumeric(Sheets("T戦績").Range("CT8")) Then
CopyToSheetCheck Sheets("T戦績").Range("CT8"), sr
DataDisp sr
Else
Beep
End If
End If
End Sub
'最終レコード
Private Sub CommandButton6_Click()
Dim sr As String
If FindMax(sr) Then
DataDisp sr
Else
Beep
End If
End Sub
'T戦績から戦績入力へコピー
Private Sub DataDisp(srow As String)
Dim i As Integer
Dim scell1 As String
Dim scell2 As String
'回数
Range("F2") = Sheets("T戦績").Range(srow)
'前、次ボタン用のセル位置
Sheets("T戦績").Range("CR8") = "<=" & Range("F2")
Sheets("T戦績").Range("CR9") = ">=" & Range("F2")
'日付
Range("H2") = Sheets("T戦績").Range(srow).Offset(0, 1)
Range("F5").Select
'T戦績コピー開始位置
scell1 = A1Add(srow, 0, 2)
scell2 = A1Add(scell1, 0, 2) & ":" & A1Add(scell1, 0, 4)
For i = 0 To 12
'コピー
Sheets("T戦績").Range(scell1).Copy Destination:=Range("F5").Offset(i, 0)
Sheets("T戦績").Range(scell2).Copy Destination:=Range("H5").Offset(i, 0)
scell1 = A1Add(scell1, 0, 7)
scell2 = A1Add(scell1, 0, 2) & ":" & A1Add(scell1, 0, 4)
Next
End Sub
'指定範囲から最大値を検索
Private Function FindMax(ByRef srow As String) As Boolean
Dim ans As Long
Dim tRange As Range
FindMax = False
'1列目の最大値を捜す
Set tRange = Sheets("T戦績").Columns(1)
ans = Application.WorksheetFunction.Max(tRange)
'最大値のセルを取得
Set tRange = tRange.Find(What:=ans, LookIn:=xlValues, LookAt:=xlWhole)
If Not tRange Is Nothing Then
srow = tRange.Address(RowAbsolute:=False, ColumnAbsolute:=False)
FindMax = True
End If
End Function
'指定範囲から最小値を検索
Private Function FindMin(ByRef srow As String) As Boolean
Dim ans As Long
Dim tRange As Range
FindMin = False
'1列目の最小値を捜す
Set tRange = Sheets("T戦績").Columns(1)
ans = Application.WorksheetFunction.Min(tRange)
'最小値のセルを取得
Set tRange = tRange.Find(What:=ans, LookIn:=xlValues, LookAt:=xlWhole)
If Not tRange Is Nothing Then
srow = tRange.Address(RowAbsolute:=False, ColumnAbsolute:=False)
FindMin = True
End If
End Function
下記のコードを変更してください
'回数が登録されているかチェック
Private Function CopyToSheetCheck(kaisu As Long, ByRef srow As String) As Boolean
Dim lrow As Long
Dim tRange As Range
Dim s As String
srow = ""
CopyToSheetCheck = False
s = ""
lrow = Sheets("T戦績").Range("A65536").End(xlUp).Row
If lrow = 7 Then
srow = "A8"
Else
Set tRange = Sheets("T戦績"). _
Range("A8", Sheets("T戦績").Range("A8").Offset(rowOffset:=lrow)). _
Find(What:=kaisu, LookIn:=xlValues) '
If Not tRange Is Nothing Then
srow = tRange.Address
CopyToSheetCheck = True
Else
srow = "A" & lrow + 1
End If
End If
End Function
|
|
