処理速度を速くする方法教えてください。

質問

Private Sub CommandButton1_Click()
Dim irow As Long
Dim Celldata(1 To 6) As Double
Dim ekimen(1 To 6) As String '高さ読込み

If TextBox8.Value = "" Then
MsgBox ("No.を入力")
End
End If

If TextBox9.Value = "" Then
MsgBox ("温度を入力")
End
End If

If TextBox10.Value = "" Then
MsgBox ("係数を入力")
End
End If

Celldata(1) = TextBox1.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value
Celldata(2) = TextBox2.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value
Celldata(3) = TextBox3.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value
Celldata(4) = TextBox4.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value
Celldata(5) = TextBox5.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value
Celldata(6) = TextBox6.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value

'入力と修正
Dim i As Long
'最終行から試験Noが一致するものを探す
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(TextBox8.Value) Then
Set myrange = Sheets("データ").Cells(i - 1, 1)
'記入セルがoffset(1,x)になっているため、i-1にしています。
Exit For
End If
Next i

'Noが一致しない場合、最終行を記入セルに設定する。
If i = 5 Then
Set myrange = Sheets("データ").Range("A65536").End(xlUp)
End If

'ワークシートへの転記
With myrange

.Offset(1, 0).Value = TextBox8.Value '----No.
.Offset(1, 1).Value = Celldata(1) '----１計測
.Offset(1, 2).Value = Celldata(2) '----２計測
.Offset(1, 3).Value = Celldata(3) '----３ル計測
.Offset(1, 4).Value = Celldata(4) '----４計測
.Offset(1, 5).Value = Celldata(5) '----５計測
.Offset(1, 6).Value = Celldata(6) '----６計測
.Offset(1, 13).Value = TextBox1.Value '----１追加
.Offset(1, 14).Value = TextBox2.Value '----２追加
.Offset(1, 15).Value = TextBox3.Value '----３追加
.Offset(1, 16).Value = TextBox4.Value '----４追加
.Offset(1, 17).Value = TextBox5.Value '----５追加
.Offset(1, 18).Value = TextBox6.Value '----６追加
.Offset(1, 19).Value = TextBox7.Value '---温度
.Offset(1, 20).Value = TextBox11.Value '----１高さ
.Offset(1, 21).Value = TextBox12.Value '----２高さ
.Offset(1, 22).Value = TextBox13.Value '----３高さ
.Offset(1, 23).Value = TextBox14.Value '----４高さ
.Offset(1, 24).Value = TextBox15.Value '----５高さ
.Offset(1, 25).Value = TextBox16.Value '----６高さ

'入力ボックスのクリア
TextBox1.Value = "" '----1セル
TextBox2.Value = "" '----2セル
TextBox3.Value = "" '----3セル
TextBox4.Value = "" '----4セル
TextBox5.Value = "" '----5セル
TextBox6.Value = "" '----6セル
TextBox7.Value = "" '---温度
TextBox11.Value = "" '----1セル
TextBox12.Value = "" '----2セル
TextBox13.Value = "" '----3セル
TextBox14.Value = "" '----4セル
TextBox15.Value = "" '----5セル
TextBox16.Value = "" '----6セル
End With
'lblComment.Caption = "ワークシートに転記しました！"
End Sub

Private Sub CommandButton2_Click()
Dim i As Long
'入力チェック
If TextBox8.Value = "" Then
MsgBox ("No.を入力")
End
End If

If TextBox9.Value = "" Then
MsgBox ("温度を入力")
End
End If

If TextBox10.Value = "" Then
MsgBox ("係数を入力")
End
End If

For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(TextBox8.Value) Then
Set myrange = Sheets("データ").Cells(i - 1, 1)
'記入セルがoffset(1,x)になっているため、i-1にしています。
Exit For
End If
Next i

'受付No.がない場合、終了します。
If i = 5 Then
MsgBox ("No.が見つかりません")
End
End If

'入力の処理と逆の処理を行います。
With myrange
TextBox1.Value = .Offset(1, 13).Value '---１計測
TextBox2.Value = .Offset(1, 14).Value '---２計測
TextBox3.Value = .Offset(1, 15).Value '---３計測
TextBox4.Value = .Offset(1, 16).Value '---４計測
TextBox5.Value = .Offset(1, 17).Value '---５計測
TextBox6.Value = .Offset(1, 18).Value '---６計測
TextBox7.Value = .Offset(1, 19).Value '---温度
TextBox11.Value = .Offset(1, 20).Value '---１高さ
TextBox12.Value = .Offset(1, 21).Value '---２高さ
TextBox13.Value = .Offset(1, 22).Value '---３高さ
TextBox14.Value = .Offset(1, 23).Value '---４高さ
TextBox15.Value = .Offset(1, 24).Value '---５高さ
TextBox16.Value = .Offset(1, 25).Value '---６高さ
End With
End Sub

回答No.2

cj_mover · ベストアンサー

CommandButton1_Click()を例に、何をどう書き換えたのか対応を書きました。
モジュールに貼付けた方が多少読み易いと思います。
コメントブロック外せば、＃１と全く同じ内容です。

Private Sub Re8107868()
'Dim ekimen(1 To 6) As String '高さ読込み ' 未使用？
'Dim Celldata(1 To 6) As Double
' ' ▼
　　Dim Celldata(0 To 6) As Double '----No. １-６計測
　　Dim CellDataB(1 To 13) As Double '----１-６追加 温度 １-６高さ ' ★追加
' ' ▲
　　Dim dblT As Double ' ★追加
　　Dim nTarget As Long ' ★追加
'Dim myrange As Range
'Dim irow As Long ' 未使用？
　　Dim i As Long

　　If TextBox8.Value = "" Then
　　　　MsgBox ("No.を入力")
'End
' ' ▼
　　　　Me.Hide ' ★
　　　　Exit Sub ' ★
' ' ▲
'End If
'If TextBox9.Value = "" Then
' ' ▼
　　ElseIf TextBox9.Value = "" Then
' ' ▲
　　　　MsgBox ("温度を入力")
'End
' ' ▼
　　　　Me.Hide ' ★
　　　　Exit Sub ' ★
' ' ▲
'End If
'If TextBox10.Value = "" Then
' ' ▼
　　ElseIf TextBox10.Value = "" Then
' ' ▲
　　　　MsgBox ("係数を入力")
'End
' ' ▼
　　　　Me.Hide ' ★
　　　　Exit Sub ' ★
' ' ▲
　　End If

'.Offset(1, 0).Value = TextBox8.Value '----No.
' ' ▼
　　Celldata(0) = CLng(TextBox8.Value) '----No.
' ' ▲
　　With Me.Controls ' ★追加
'Celldata(1) = TextBox1.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value
'Celldata(2) = TextBox2.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value
'Celldata(3) = TextBox3.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value
'Celldata(4) = TextBox4.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value
'Celldata(5) = TextBox5.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value
'Celldata(6) = TextBox6.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value
' ' ▼
　　　　dblT = (CDbl(TextBox7.Value) - CDbl(TextBox9.Value)) * CDbl(TextBox10.Value)
　　　　For i = 1 To 6
　　　　　　Celldata(i) = dblT + CDbl(.Item("TextBox" & i).Value) '----１-６計測
　　　　Next i
' ' ▲
'.Offset(1, 13).Value = TextBox1.Value '----１追加
'.Offset(1, 14).Value = TextBox2.Value '----２追加
'.Offset(1, 15).Value = TextBox3.Value '----３追加
'.Offset(1, 16).Value = TextBox4.Value '----４追加
'.Offset(1, 17).Value = TextBox5.Value '----５追加
'.Offset(1, 18).Value = TextBox6.Value '----６追加
'.Offset(1, 19).Value = TextBox7.Value '---温度
' ' ▼
　　　　For i = 1 To 7
　　　　　　CellDataB(i) = CDbl(.Item("TextBox" & i).Value) '----１-６追加 温度
　　　　Next i
' ' ▲
'.Offset(1, 20).Value = TextBox11.Value '----１高さ
'.Offset(1, 21).Value = TextBox12.Value '----２高さ
'.Offset(1, 22).Value = TextBox13.Value '----３高さ
'.Offset(1, 23).Value = TextBox14.Value '----４高さ
'.Offset(1, 24).Value = TextBox15.Value '----５高さ
'.Offset(1, 25).Value = TextBox16.Value '----６高さ
' ' ▼
　　　　For i = 11 To 16
　　　　　　CellDataB(i - 3) = CDbl(.Item("TextBox" & i).Value) '----１-６高さ
　　　　Next i
' ' ▲
''入力ボックスのクリア
'TextBox1.Value = "" '----1セル
'TextBox2.Value = "" '----2セル
'TextBox3.Value = "" '----3セル
'TextBox4.Value = "" '----4セル
'TextBox5.Value = "" '----5セル
'TextBox6.Value = "" '----6セル
'TextBox7.Value = "" '---温度
'TextBox11.Value = "" '----1セル
'TextBox12.Value = "" '----2セル
'TextBox13.Value = "" '----3セル
'TextBox14.Value = "" '----4セル
'TextBox15.Value = "" '----5セル
'TextBox16.Value = "" '----6セル
' ' ▼
　　　　For i = 1 To 7
　　　　　　.Item("TextBox" & i).Value = ""
　　　　Next i
　　　　For i = 11 To 16
　　　　　　.Item("TextBox" & i).Value = ""
　　　　Next i
' ' ▲
　　End With ' With Me.Controls ' ★追加

'入力と修正
　　With Sheets("データ") ' ★追加
'最終行から試験Noが一致するものを探す
'For i = 65535 To 6 Step -1
'If CStr(Cells(i, 1)) = Trim(TextBox8.Value) Then
'Set myrange = Sheets("データ").Cells(i - 1, 1)
''記入セルがoffset(1,x)になっているため、i-1にしています。
'Exit For
'End If
'Next i
' ' ▼
　　　　nTarget = CLng(TextBox8.Value)
　　　　For i = .Cells(Rows.Count, 1).End(xlUp).Row To 6 Step -1
　　　　　　If .Cells(i, 1) = nTarget Then Exit For
　　　　Next i
' ' ▲
'Noが一致しない場合、最終行を記入セルに設定する。
'If i = 5 Then
'Set myrange = Sheets("データ").Range("A65536").End(xlUp)
'End If
' ' ▼
　　　　If i = 5 Then i = .Cells(Rows.Count, 1).End(xlUp).Row + 1
' ' ▲ 変数 i が、そのまま、出力先の行位置を指す。

'ワークシートへの転記
'With myrange
' ...
'End With
' ' ▼
'ワークシートへの転記（配列変数を出力）
　　　　.Cells(i, 1).Resize(, 6).Value = Celldata() '----No. １-６計測
　　　　.Cells(i, 13).Resize(, 13).Value = CellDataB() '----１-６追加 温度 １-６高さ
' ' ▲
　　End With ' With Sheets("データ") ' ★追加

End Sub

お礼

質問でsheet名を間違えておりましたので、混乱をさせてしまい申し訳ありませんでした。

回答No.3

cj_mover

試しにサンプル作って走らせました。
結果、コーディングのミスに気が付きましたので訂正です。

誤）
　　　　.Cells(i, 1).Resize(, 6).Value = Celldata()
正）
　　　　.Cells(i, 1).Resize(, 7).Value = Celldata()

以上、失礼しました。

それと、
> 　扱うシートは、Sheets("データ")　だけ。
というこちらの前提が違うような気もしています。
２つのシート間でデータのやり取りをしている？のだとすると
そちらで修正して貰う必要があります。
　　.Cells(...
と書いてあるのが、
　　Sheets("データ")
のセルという意味で、すべて統一してあります。
これを
　　Cells(...
と書き換えるとSheets("データ")ではなくて
　　ActivaSheet
のセルという意味になります。
もし、こちらの誤解だったなら、
書き換えてみながら修正を加えてみてください。

取り急ぎ、以上です。

お礼

返事が遅くなり申し訳ありません。仕事の都合でマクロを作成することになり、周囲の方に教えてもらいながら、作成しております。何度も作り変えておりますので不要なマクロが残っておりました。教えていただけるだけでも感謝しているところ、修正いただき有難うございました。

補足

扱うシートは、Sheets("データ")　だけで行っております。集計は別のマクロを利用しています。

回答No.1

cj_mover

こんにちは。
イメージを読み取ることが出来ないので、ちょっと苦しいですが、
類推を交えて、書いてみました。
今回はサンプルを作成せずにコードだけ書いてテストも検証も無しで
進めるよりないので、一発で正解してなくても、ご勘弁を。
///
　扱うシートは、Sheets("データ")　だけ。
　扱うデータは、すべて、小数点数（Double）
　ご提示のコードがすべてで、各プロシージャに他の既述がないこと。
など、未確認の前提で書いています。
///
　With ステートメント の扱い
　For...Next ループでTextBoxを捉える方法
　配列変数の受け渡し
　If...Then...ElseIf...Then...End If の扱い
　End は使わないこと
　代わりに Exit Sub すること
　ループの中の固定値は事前に変数に格納すること
　シートの行数は Rows.Count で取得
　最終行を End プロパティで取得すること
　Range オブジェクトをセットする代わりに行位置だけ取得すること
などが、変更点で、覚えて欲しいポイントでもあります。
///
CDbl()は、そう書かないと困る場合を想定していますが、
そう書くことでエラーになる場合もあるかも知れませんので
CDbl()の行でエラーがでたら、CDbl()をはずしてください。
///
Dim CellDataB(1 To 13) As Double
は、もしかして実際に合わないかも知れませんので
Dim CellDataB(1 To 13)
と書き換えてもらってもいいです。
///
文字数制限の都合で連続で投稿します。
次の投稿では、CommandButton1_Click()　を例に、
何をどう書き換えたのか、対応を示しておきます。
///
とりあえず、バックアップの上、試してみてください。

' ' 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

Private Sub CommandButton1_Click() ' Re8107868-1
　　Dim Celldata(0 To 6) As Double '----No. １-６計測
　　Dim CellDataB(1 To 13) As Double '----１-６追加 温度 １-６高さ ' ★追加
　　Dim dblT As Double ' ★追加
　　Dim nTarget As Long ' ★追加
　　Dim i As Long

' ' 入力チェック
　　If TextBox8.Value = "" Then
　　　　MsgBox ("No.を入力")
　　　　Me.Hide ' ★
　　　　Exit Sub ' ★
　　ElseIf TextBox9.Value = "" Then
　　　　MsgBox ("温度を入力")
　　　　Me.Hide ' ★
　　　　Exit Sub ' ★
　　ElseIf TextBox10.Value = "" Then
　　　　MsgBox ("係数を入力")
　　　　Me.Hide ' ★
　　　　Exit Sub ' ★
　　End If

' '----No.
　　Celldata(0) = CLng(TextBox8.Value)
　　With Me.Controls ' ★追加
' '----１-６計測
　　　　dblT = (CDbl(TextBox7.Value) - CDbl(TextBox9.Value)) * CDbl(TextBox10.Value)
　　　　For i = 1 To 6
　　　　　　Celldata(i) = dblT + CDbl(.Item("TextBox" & i).Value)
　　　　Next i
' '----１-６追加 温度
　　　　For i = 1 To 7
　　　　　　CellDataB(i) = CDbl(.Item("TextBox" & i).Value)
　　　　Next i
' '----１-６高さ
　　　　For i = 11 To 16
　　　　　　CellDataB(i - 3) = CDbl(.Item("TextBox" & i).Value)
　　　　Next i
' '入力ボックスのクリア
　　　　For i = 1 To 7
　　　　　　.Item("TextBox" & i).Value = ""
　　　　Next i
　　　　For i = 11 To 16
　　　　　　.Item("TextBox" & i).Value = ""
　　　　Next i
　　End With

　　With Sheets("データ") ' ★追加
' ' 最終行から試験Noが一致するものを探す
　　　　nTarget = CLng(TextBox8.Value)
　　　　For i = .Cells(Rows.Count, 1).End(xlUp).Row To 6 Step -1
　　　　　　If .Cells(i, 1) = nTarget Then Exit For
　　　　Next i
' 'Noが一致しない場合、最終行を記入セルに設定する。
　　　　If i = 5 Then i = .Cells(Rows.Count, 1).End(xlUp).Row + 1
' ' 変数 i が、そのまま、出力先の行位置を指す。

' ' ワークシートへの転記（配列変数を出力）
　　　　.Cells(i, 1).Resize(, 6).Value = Celldata() '----No. １-６計測
　　　　.Cells(i, 13).Resize(, 13).Value = CellDataB() '----１-６追加 温度 １-６高さ
　　End With

' ' lblComment.Caption = "ワークシートに転記しました！"
End Sub

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Private Sub CommandButton2_Click() ' Re8107868-2
　　Dim mtxV()
　　Dim nTarget As Long
　　Dim i As Long

' ' 入力チェック
　　If TextBox8.Value = "" Then
　　　　MsgBox ("No.を入力")
　　　　Me.Hide
　　　　Exit Sub
　　ElseIf TextBox9.Value = "" Then
　　　　MsgBox ("温度を入力")
　　　　Me.Hide
　　　　Exit Sub
　　ElseIf TextBox10.Value = "" Then
　　　　MsgBox ("係数を入力")
　　　　Me.Hide
　　　　Exit Sub
　　End If

　　With Sheets("データ")
' ' 最終行から試験Noが一致するものを探す
　　　　nTarget = CLng(TextBox8.Value)
　　　　For i = .Cells(Rows.Count, 1).End(xlUp).Row To 6 Step -1
　　　　　　If .Cells(i, 1) = nTarget Then Exit For
　　　　Next i

' ' 受付No.がない場合、終了します。
　　　　If i = 5 Then
　　　　　　MsgBox ("No.が見つかりません")
　　　　　　Me.Hide
　　　　　　Exit Sub
　　　　End If
' ' 該する行位置 i 行の 13列めのセルから13列分 のデータを配列変数に格納
　　　　mtxV() = .Cells(i, 13).Resize(, 13).Value
　　End With

' ' 入力の処理と逆の処理を行います。
　　With Me.Controls
' '----１-６追加 温度
　　　　For i = 1 To 7
　　　　　　.Item("TextBox" & i).Value = mtxV(1, i)
　　　　Next i
' '----１-６高さ
　　　　For i = 8 To 13
　　　　　　.Item("TextBox" & i + 3).Value = mtxV(1, i)
　　　　Next i
　　End With

　　Erase mtxV()
End Sub

' ' 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

お礼

返事が遅くなり申し訳ありません。本日試しましたところ、一部ずれがありましたが、修正し問題なく動作しました。有難うございました。