過去のリンクhttp://okwave.jp/qa

質問

過去のリンクhttp://okwave.jp/qa9671557.html

いつもありがとうございます。今回はシート1のA3セルに4901777という数字を入れた時にC4セルに改行された時にNAME1と表示されるコード、、なのですが、試作だけにコードの見映えがよくありません。何十何百となった時にコードが冗長化しそうです。スリムなコードにするにはどうしたら良いでしょうか？

よろしくお願いします^^

' ///Sheet1///

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

Dim time7 As Range

For Each time7 In Target
If time7.Column = 1 Then
time7.Offset(0, 4).Value = Format(Now, "Short Time") & vbCrLf & _
Format(Now, "yyyy/mm/dd hh:nn:ss AM/PM")
End If

Application.EnableEvents = False

Application.EnableEvents = True

Next time7

'(1)シートを変数にセット
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")

'(2)シートを指定してデータを転記
ws2.Range("A3:E3").Value = ws1.Range("A3:E3 ").Value

Set ws1 = Nothing
Set ws2 = Nothing

End Sub

Private Sub Worksheet_Activate()
'
' 新規行挿入
'

'

Worksheets("Sheet2").Range("3:3").Insert

Sheets("Sheet1").Range("H3").Select
ActiveCell.FormulaR1C1 = "5"
Sheets("Sheet1").Range("E3").Select
Selection.ClearContents

Dim str_Left As String

'セルE4に文字列、セルH4に数字を予め入れておくこと。
str_Left = Left(Cells(4, 5), Cells(4, 8))

MsgBox str_Left & vbCrLf & " " & "OKボタンを押してください!"

Sheets("Sheet1").Range("A3").Select

Dim se_r As String
se_r = Application.InputBox("バーコードを入力してください")
Select Case se_r
Case "False"
MsgBox "キャンセルされました"
Case ""
MsgBox "空欄が入力されました"
Case Else
Range("A3").Value = se_r
End Select

End Sub

' ///Sheet2///

Private Sub Worksheet_Activate()

Dim Emp(1 To 300) As String
Dim msg As String
Dim i, i2, Cnt As Integer
Dim N_In As Variant

For i = 3 To 3
If IsEmpty(Cells(i, 1).Value) = False Then 'ここで空欄判定
Worksheets("Sheet1").Range("3:3").Insert '対象セルアドレスを改行処理
End If
Application.EnableEvents = True

'(1)シートを変数にセット
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim st1, s, i3 As Long
Dim Bst As Range
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")

'(2)シートを指定してデータを転記

st1 = ws1.Cells(Rows.Count, "E").End(xlUp).Row 'A列の最終行を設定する
s = 3
For i3 = 3 To st1

Set Bst = ws2.Columns("E").Find(What:=ws1.Cells(i3, "E"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
'A列とE列を比較

If Bst Is Nothing Then '比較して無い場合は、下記を実行

ws2.Cells(s, "A") = ws1.Cells(i3, "A") '追加する文字を転記する。（コード）
ws2.Cells(s, "C") = Mid(ws1.Cells(i3, "A"), 3, 5) '追加する文字を転記する。（コード2）
s = s + 1

End If

Next i3 'A列データの最終行までループ

Next i

ws2.Range("C3:C300").Replace What:="01777", Replacement:="NAME1", LookAt:=xlPart, MatchCase:=True
ws1.Range("C4").Value = ws2.Range("C3").Value
ws1.Activate

Set ws1 = Nothing
Set ws2 = Nothing

End Sub

回答No.3

kkkkkm

> もっと努力なり才能なりがあれば、エラーを正確に検出出来たのですが、、。

エラーメッセージとVBAの止まった箇所(確か黄色で反転してる)でほとんどの場合はわかると思います。

> 確かなのは置換しないと入力作業に負担が行きます。基本的に1・2・3で入力出来ればなと思っています。

1を入力したら山田太郎に置換
2を入力したら田中一郎に置換
3を入力したら吉田茂に置換
以下50とか100とかある感じでしょうか

数字毎に対応した別表が必要になります。大量になればその対応表を覚えるのが大変かも。

> 表形式にまとめる→必要箇所だけ抜き取る(保存する)

新しいブックに必要なシート(シートに不要な部分があれば範囲)をコピーして保存する。

補足

小規模な話しなので使うのはせいぜい全部で20～30項目です。使うか使わないか分からないのが倍以上あるかも知れないけれど、です。細かく別けるとそんな感じです。中規模なれば100項目以上かも知れませんが、、。作るにあたり、データに何かあっても大丈夫なのから数値化しようとしてますが、、ただ何かなくても保存は出来るようにしたいです。また、日に50～100も入力すれば済むものですが、その項目コードの細分化も難しいというか規模こそではあって対応コードにするのは一工夫要ります。

日別、週間、月間、、過去履歴を閲覧できるデータベース仕様のに落とし込めれば完成ですが、長い話しですね。

特徴あるというか、我ながらな作りにできれば利用価値はあるかな。。

回答No.2

kkkkkm

> 9401777→01777→NAME1
> という元の文字列から取得(01777)→置換(NAME1)をしたコード

このコードがかなりの回数実行される(回数分記載する)のを回避したいということでしたら
先に書いたように実数を変数に入れてループするという処理になると思います。

> 今のところ固定的に発現してくるので問題としていません。

一定の操作でエラーになるのでしたら、原因は分かりやすいと思いますが、問題としていないという事ですので第三者が口をはさむこともないみたいですし、その操作をしなければいいだけという事になりそうですね。

お礼

CSV形式等でファイルに保存できれば、次は別のコードでとも考えています。

入力→『表形式にまとめる→必要箇所だけ抜き取る(保存する)』→別のコードで…

今回の繰り返し質問は『』内の質問になります。

またシート1とシート2に分けていますが、別のコードにすることで、、シート1が入力画面兼表形式でシート2が作業シートにしようかと思っています。

補足

もっと努力なり才能なりがあれば、エラーを正確に検出出来たのですが、、。

ある数字の文字列には一意の文字列を付ける予定です。
B列
1→名前1
2→名前2
3→名前3
…

さらに
C列
101→ストレッチ
102→ウォーキング
103→ランニング
…

等のような。

D列も使えるのですが、、VBAのコードばかりでなく、バーコードの方で調整できないか思案してます。

確かなのは置換しないと入力作業に負担が行きます。基本的に1・2・3で入力出来ればなと思っています。

回答No.1

kkkkkm

> 試作だけにコードの見映えがよくありません

どの部分でしょうか。すべてにおいてということでしょうか。

> 何十何百となった時に

「4901777」の数字が何十何百となったときということでしょうか。
としたら

どこかのシートのX列に数字のデータを何十何百と入れておいて
(NAME1が変化するのでいたらそちらを対象に変更して)

For i = 1 To Cells(Rows.Count, "X").End(xlUp).Row
Fstr = どこかのシート.Cells(i, "X").Value
ws2.Range("C3:C300").Replace What:=Fstr, Replacement:="NAME1", LookAt:=xlPart, MatchCase:=True
Next

前回
Set ws1 = Nothing
とオブジェクトを解放する癖をつけておいた方がいいとだけしか書かなくて説明不足だったのでここで追記させてください。
最後までオブジェクトを解放していない場合、(Set ws1 = Nothingがない場合)
End Sub
で解放されるので、実際最後までオブジェクトを利用している場合は
Set ws1 = Nothing
を記載しなくてもほとんど問題は無いと思います。記載していると無駄だと指摘されるかもしれません。

ただ、処理によってはオブジェクトを利用しなくなって「すぐ」に解放しないと不都合が起こる可能性があります。そのために、解放する癖をつけておいた方がいいですよ、という説明になりました。

あと。、余計なお世話かもしれませんが、問題がありそうなコードで次々と機能を追加していくと、エラーが出たときにどこが問題なのか見つけるのに苦労すると思いますよ。

お礼

9401777→01777→NAME1
という元の文字列から取得(01777)→置換(NAME1)をしたコードですが、、というのです。この部分のコードについてでした。

完成形からすれば、せめてコードはキレイに書くべきですね。また、修正が必要な箇所が最低1箇所あります。よく分からないエラー擬が1つほどあります。他にもExcelが動作不良になる場合も。その為ではないですが、色々試行錯誤しながらコードを追加しています。エラーの出方や特徴も知りたいですし、、。

今のところ固定的に発現してくるので問題としていません。理由等々分かれば書き直すのですが、、。

繰り返しの質問に回答ありがとうございます。

補足

参考になります。ありがとうございます^^

完成されたコードを目指していたら、全てにおいてでしょう。しかし、コードの問題よりは、生産性的に効率よく書けるだけで良いです。最終的には整理して分類してスマートな記述を目指してなどになりますが、一旦完成形にすると、、それ以上を必要としないとは思います。生産性的に必要以上のコードは要らないと思いますから、、。

目につく辺りはあると思いますが、そこに可能性があると信じています。間違いもあるが？

そんな感じですが、考えている内容の違いと思ってください。

回答参考にさせてもらいます。