過去のリンク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
お礼
ありがとうございます。できました。 Anchor:=Cells(rw1, 2) でも動いてます。