特定の文字以外を入力すると別シートに表記する方法
- VBAを使用して特定の文字以外を入力すると、別のシートに自動的に表記する方法を紹介します。
- Worksheet_Changeイベントを使用して、セルの変更を監視します。
- 変更が特定のセルの場合、ハイフンが含まれていない場合にのみデータを別のシートに転送します。
- ベストアンサー
特定の文字以外を入力すると別シートに表記する方法
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim StrRow As Long Dim TgtCol As Long Dim MaxRow As Long Dim ChgRow As Long Dim PutSh1 As Worksheet Dim PutSh2 As Worksheet Dim PutSh3 As Worksheet Dim PutCol As Long Dim PutRow As Long Dim ChgRng1 As Range Dim ChgRng2 As Range Dim ChgRng3 As Range StrRow = 5 MaxRow = 35 If Target.Count > 1 Then Exit Sub If Target.Value = "" Then Exit Sub Set PutSh1 = ThisWorkbook.Sheets("Sheet2") Set PutSh2 = ThisWorkbook.Sheets("Sheet3") Set PutSh3 = ThisWorkbook.Sheets("Sheet4") With ThisWorkbook.Sheets("Sheet1") Set ChgRng1 = Range(.Cells(StrRow, 3), .Cells(MaxRow, 3)) 'C列 Set ChgRng2 = Range(.Cells(StrRow, 5), .Cells(MaxRow, 5)) 'E列 Set ChgRng3 = Range(.Cells(StrRow, 7), .Cells(MaxRow, 7)) 'G列 End With ChgRow = Target.Row If Not Intersect(Target, ChgRng1) Is Nothing Then Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1 DataPut PutSh1, ChgRow, Target.Value End If If Not Intersect(Target, ChgRng2) Is Nothing Then Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1 DataPut PutSh2, ChgRow, Target.Value End If If Not Intersect(Target, ChgRng3) Is Nothing Then Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1 DataPut PutSh3, ChgRow, Target.Value End If End Sub 以前質問させて頂いた内容で追加の質問です。 Sheet1の指定したセルに「ー（ハイフン）」の文字がある時は、Sheet2〜4に転送（表記）しない方法を追加する場合はどの様にすれば宜しいでしょうか？
- kxsst808
- お礼率100% (12/12)
- Excel（エクセル）
- 回答数2
- ありがとう数2
- みんなの回答 （2）
- 専門家の回答
質問者が選んだベストアンサー
追記です。 >Sheet1の指定したセルに「ー（ハイフン）」の文字 この文字はハイフンではなく長音です。 全角のマイナスの文字であれば、 「－」です。 もし後者なら、コードは以下です。 Private Sub Worksheet_Change(ByVal Target As Range) '途中要略 Dim ChgRng3 As Range If InStr(Target, "－") > 0 Then Exit Sub StrRow = 5 '以下省略 もし半角のマイナスなら If InStr(Target, "－") > 0 Then Exit Sub ではなく If InStr(Target, "-") > 0 Then Exit Sub となります。
その他の回答 (1)
- HohoPapa
- ベストアンサー率65% (454/690)
入力した値に全角の"ー"が含まれていたら 何もせずに抜ける ということでよければ 以下です。 Private Sub Worksheet_Change(ByVal Target As Range) '途中要略 Dim ChgRng3 As Range If InStr(Target, "ー") > 0 Then Exit Sub StrRow = 5 '以下省略
お礼
ありがとうございます！ 非常に助かりました。 また宜しくお願いします。
関連するQ&A
- ブック内に特定名のシートがある場合
はじめまして、こんにちは。 ＶＢＡを最近はじめたばかりの者です。質問が初歩的なもので申し訳ないのですが是非教えてください。 以下を使って、複数ブックの○○というシートから指定セルの内容を抜き出したいと思っています。 ところが、ブックによっては○○というシートが存在しない場合があり、その場合には「インデックスが有効でない」というエラーで動作が止まってしまいます。 ブック内に○○というシートがある場合にのみ動作させるようにするにはどのようにすれば良いのでしょうか。 よろしくお願いします。 Dim wb As Workbook, myRow As Long Dim e As Integer myRow = ThisWorkbook.Worksheets(1).Rows.Count With Application.FileSearch .NewSearch .LookIn = ThisWorkbook.Path .SearchSubFolders = True .FileType = msoFileTypeExcelWorkbooks If .Execute() > 0 Then For i = 1 To .FoundFiles.Count If .FoundFiles(i) <> ThisWorkbook.FullName Then Set wb = Workbooks.Open(.FoundFiles(i), UpdateLinks:=0) Application.ScreenUpdating = False ThisWorkbook.Worksheets(1).Range("A" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("F6").Value ThisWorkbook.Worksheets(1).Range("B" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("F7").Value ThisWorkbook.Worksheets(1).Range("C" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("F8").Value ThisWorkbook.Worksheets(1).Range("D" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("Y6").Value wb.Close False End If Next i Else MsgBox "ファイルがありません。" End If End With End Sub
- ベストアンサー
- Visual Basic
- エクセルの簡単なマクロ機能を追加したいのです
既存のエクセルマクロ（Sub チェック()以下です）に下記の内容のマクロを付け足したいです。 教えていただけないでしょうか。 付け足したい条件です： Sheet2のC列に 0 があれば Sheet1のB列に 愛 と（[太字]でセルの背景色を[灰色25%]にして）入れたいです 恐れ入りますがご存じの方がいらっしゃりましたら教えていただきたく何卒よろしくお願いいたします。 ----------------------------------------------- Sub チェック() Dim Ws1 As Worksheet Dim Ws2 As Worksheet Dim myRange1 As Range Dim myRange2 As Range Dim c1 As Range Dim c2 As Range Dim myCt As Long Set Ws1 = Worksheets("Sheet1") Set Ws2 = Worksheets("Sheet2") Set myRange1 = Ws1.Range("A1", Ws1.Cells(Rows.Count, "A").End(xlUp)) Set myRange2 = Ws2.Range("A1", Ws2.Cells(Rows.Count, "A").End(xlUp)) For Each c1 In myRange1 myCt = 0 For Each c2 In myRange2 If c2.Value = c1.Value Then If c2.Offset(, 1).Value = "" Then c1.Offset(, 1).Interior.ColorIndex = 3 Else c1.Offset(, 1).Value = c2.Offset(, 1).Value End If myCt = myCt + 1 End If Next c2 If myCt > 1 Then c1.Offset(, 1).Interior.ColorIndex = 10 Next c1 Set Ws1 = Nothing Set Ws2 = Nothing Set myRange1 = Nothing Set myRange2 = Nothing End Sub
- 締切済み
- その他MS Office製品
- エクセルマクロ 特定の文字入力の際の処理(2)
お世話になります。 以前、下記質問をし、締め切ったのですが、もう一点、教えていただきたい点がありました。 質問 エクセルマクロで、sheet1のE列の6～30行に指定する文字が入力された際、 B列のその同じ行にある文字を取得し、その取得した文字をsheet3のC6から K6まで書き出していきたいのですが、どのようにしたらよいでしょうか？ ご回答 Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long Dim r As Range Const 指定文字 As String = "X" Set r = Range("E6:E30") If Target.Count > 1 Then Exit Sub If Intersect(r, Target) Is Nothing Then Exit Sub End If If Target.Value <> 指定文字 Then Exit Sub Else '大文字小文字を区別する場合 i = ActiveSheet.Evaluate( _ "SumProduct(EXACT(" & r.Address & ",""" & 指定文字 & """)*1)") '大文字小文字を区別しない場合 i = WorksheetFunction.CountIf(r, 指定文字) Application.EnableEvents = False Worksheets("Sheet3").Cells(6, i + 2) = _ Target.Offset(, -3) Application.EnableEvents = True End If End Sub このご回答を、 取得した文字をsheet3のC6からK6までに4列毎に書き出して いく場合にはコードをどのようにしていけば良いのでしょうか。 C6→H6→M6→・・・ すみません、再度お願い致します。
- ベストアンサー
- Excel（エクセル）
- 入力規則のドロップダウンリストを連動
以下のサイトを参考に別ブックからデータを参照する方法で苦戦しています。 http://www.eurus.dti.ne.jp/yoneyama/Excel/vba/vba_validation.html Sub name_1() Dim lCol As Long, lRow As Long Dim i As Long, nName As String Dim Wb As Workbook ←追記 Set Wb = Workbooks("MyBook.xls") ←追記 On Error Resume Next With Wb.Sheets("Sheet2") lCol = .Range("A1").End(xlToRight).Column ActiveWorkbook.Names("項目リスト").Delete ActiveWorkbook.Names.Add Name:="項目リスト", _ RefersTo:=.Range(.Cells(1, 1), .Cells(1, lCol)) '----名前の定義 For i = 1 To lCol lRow = .Cells(1, i).End(xlDown).Row nName = .Cells(1, i).Value ActiveWorkbook.Names(nName).Delete .Range(.Cells(1, i), .Cells(lRow, i)).CreateNames Top:=True Next i End With End Sub Sub Macro2() name_1 With Range("A2:A10").Validation '--入力規則を削除 .Delete '--入力規則を設定 .Add Type:=xlValidateList, _ Formula1:="=項目リスト" End With '--B2セルへ入力規則を設定 With Range("B2:B10").Validation .Delete .Add Type:=xlValidateList, _ Formula1:="=IF(A2="""",A2,INDIRECT(A2))" End With End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim c As Range Dim Wb As Workbook ←追記 Set Wb = Workbooks("MyBook.xls") ←追記 If Not (Application.Intersect(Target, Range("A2:B10")) Is Nothing) Then name_1 Application.EnableEvents = False If Target.Column = 1 Then If Target.Value = "" Then Target.Offset(0, 1).Value = "" Else Set c = Wb.Sheets("Sheet2").Range(Target.Value).Find(Target.Offset(0, 1).Value, lookat:=xlWhole) ←ここでエラー If c Is Nothing Then Target.Offset(0, 1).Value = "" End If End If End If If Target.Column = 2 Then If Target.Value = "" Then Target.Offset(0, -1).Value = "" End If End If Application.EnableEvents = True End If End Sub どのように改変すれば良いのでしょうか？
- ベストアンサー
- Visual Basic
- ２つのVBAを組み合わせる方法
お世話になります、２つのVBAを組み合わせる方法で迷っています。 １つ目が Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, k As Long, myNum As Long If Intersect(Target, Range("C1,B9:B39")) Is Nothing Or Target.Count > 1 Then Exit Sub Application.EnableEvents = False With Target If .Column = 3 Then myNum = WorksheetFunction.Max(Range("B9:B39")) If IsDate(.Value) Then For i = 9 To 39 If Cells(i, "A").Value = "" Then Cells(i, "B").Value = "" Else Cells(i, "B") = myNum + i - 8 End If Next i End If Else i = .Row If .Value = "" Then Range(Cells(i + 1, "B"), Cells(39, "B")).ClearContents Else For k = i + 1 To 39 If Cells(k, "A").Value = "" Then Cells(k, "B").Value = "" Else Cells(k, "B") = Cells(k - 1, "B") + 1 End If Next k End If End If End With Application.EnableEvents = True End Sub です。 ２つめが Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = True If Intersect(Target, Range("R8:R38")) Is Nothing Then Exit Sub Application.EnableEvents = False Range(Cells(Target.Row, 18), Cells(39, 18)).Value = Target.Value Application.EnableEvents = True End Sub です。２つのPrivate Sub Worksheet_Change(ByVal Target As Range)イベントのVBAですが、どのようにして組み合わせれば良いのでしょうか？
- ベストアンサー
- Excel（エクセル）
- 別のシートにあるリストを表示する方法
すみません 検索シートから生徒シートの名前を検索したら検索シートに返されるようなマクロはどの様に書けばいいでしょうか？ イメージとしては下記のような感じです。できれば左2行目3行目の検索結果も返したいです。 よろしくお願い致します。 Sub 名前検索() Dim myrange As Range Worksheets("生徒シート").Activate Set myrange = Range("C4:AG300").Find(what:=Range("C100").Value, LookIn:=xlValues) If Not myrange Is Nothing Then Worksheets("検索シート").Activate Cells(102, "C").Value = myrange.Offset(, -3).Value Else MsgBox "該当者なし" End If End Sub
- ベストアンサー
- オフィス系ソフト
- シート内の特定のセルの範囲が変化した時、
シート内の特定のセルの範囲が変化した時、 まずＡ列の最大値を求めて、その後Ａ列とＤ列のそれぞれの条件にあった行のＡ列に 最大値＋１を表示させるようにしたいのですが動作しません。 なぜ動かないか教えて下さい。 参考までに、そのプログラムを記載します。 宜しくお願いします。 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row <= 3 Or Target.Row > 65000 And Target.Column = 4 Then Dim i, j, max As Integer max = 0 For i = 3 To Cells(Rows.Count, 1).End(xlUp).Row If max < Range("A" & i).Value Then max = Range("A" & i).Value End If Next i For j = 3 To Cells(Rows.Count, 1).End(xlUp).Row If Cells(j, 1) = "" And Not Cells(j, 4) = "" Then Cells(j, 1) = max + 1 End If Next j End If End Sub
- ベストアンサー
- Visual Basic
- ThisWorkBookモジュールとSheetモジュールの両立
エクセル２００３でマクロを組んでいます。 Sheet1,Sheet2の２つのシートがあり、 片方のシートの"A4:G10"の範囲に値を書き込むと、もう片方の同じ位置に同じ値が書き込まれるようなマクロを組みたいです。 以前ここで教えていただいたものを改変して以下を作りました（ThisWorkBookモジュールです）。 Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim r As Range Dim Num As Integer Dim S As String, Sh_name As String Sh_name = ActiveSheet.Name Set r = Intersect(Target, Range("A4:G10")) If Not (r Is Nothing) Then Application.EnableEvents = False For Num = 1 To 2 S = "Sheet" & Num If S <> Sh_name Then Worksheets(S).Range(r.Address).Value = r.Value End If Next Application.EnableEvents = True End If End Sub ここまでは正常に動作します。 また、 Sheet1とSheet2のモジュールに、 A列のセルに値が入力された場合、同じ行のC列のセルの色を塗るという記述をしています。 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 1 Then Cells(Target.Row, 3).Interior.ColorIndex = 5 End If End Sub これらを同時に生かしたいのですが、 どのように書けばいいでしょうか。 EnableEvents = False／Trueを消してしまうと、 Worksheets(S).Range(r.Address).Value = r.Valueが実行されるたびにThisWorkBookモジュールが動いているようです。 そして2回目のSet r = Intersect(Target, Range("A4:G10"))でエラーが出ます。 （エラーは出ずとも延々と(無限ではない回数)ThisWorkBookモジュールを繰り返したコードもありました。） よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- Excel VBA 入力規則
入力規則を利用して、３つのセルを連携させることを考えていますが、 不適合な値を張り付けらられた場合に拒否をする方法があるのでしょうか。 Private Sub Worksheet_Change(ByVal Target As Range) Dim ad As String Dim ma As Range Dim ma2 As Range Dim r As Range Dim r2 As Range Dim r3 As Range Dim r1 As Range Dim m As Long Dim m2 As Long Application.EnableEvents = False If Target = "" Then Range("F7").Validation.Delete Range("F7") = "" If Target.Address(0, 0) = "B7" Then Range("D7").Validation.Delete Range("D7") = "" End If GoTo EXIT_SUB End If With Worksheets("Sheet1") ad = "A4" Set r = .Range(ad) Set ma = r.MergeArea Set r1 = r.Offset(0, 1) m = Application.Match(Range("B7"), .Range(r1, .Cells(r.Row + ma.Count - 1, r1.Column)), 0) Set r2 = .Cells(r.Row + m - 1, r1.Column) Set ma2 = r2.MergeArea If Target.Address(0, 0) = "B7" Then If ma.MergeCells Then setValiS Target.Offset(0, 2), r2 Range("F7").Validation.Delete Target.Offset(0, 2) = "" Target.Offset(0, 4) = "" Else MsgBox "A列が連結されていません。" End If ElseIf Target.Address(0, 0) = "D7" Then Set r3 = r2.Offset(0, 1) m2 = Application.Match(Target, .Range(r3, .Cells(r2.Row + ma2.Count - 1, r3.Column)), 0) setValiS Target.Offset(0, 2), .Cells(r2.Row + m2 - 1, r3.Column) Target.Offset(0, 2) = "" End If End With EXIT_SUB: Application.EnableEvents = True End Sub Sub setVali2() Dim tc As Range Dim c As Range Set tc = Worksheets("登録").Range("D3") Set c = Worksheets("Sheet1").Range("C3") setValiS tc, c End Sub Sub setValiS(tc As Range, c As Range) Dim ss As String Debug.Print tc.Address, c.Address ss = getChildren(c) If ss > "" Then With tc.Validation .Delete .Add Type:=xlValidateList, Formula1:=getChildren(c) End With End If Worksheets("登録").Activate End Sub Function getChildren(c As Range) Dim c1 As Range Dim ss As String Dim s1 As String Worksheets("Sheet1").Activate ss = "" For Each c1 In c.MergeArea s1 = c1.Offset(0, 1) If s1 <> "" Then ss = ss & "," & s1 Next c1 If ss <> "" Then ss = Mid(ss, 2) Else MsgBox "データがありません！" End If getChildren = ss End Function Sub Outline() Dim CheckRow As Long Dim Moji As String Dim TopRow As Long Dim EndRow As Long With ActiveSheet .Range("A2").ClearOutline .Outline.SummaryRow = xlAbove CheckRow0 = .Range("A" & .Rows.Count).End(xlUp).Row CheckRow = CheckRow0 Do If Moji = "" Then Moji = .Cells(CheckRow, 1).Value EndRow = CheckRow ElseIf yy_mm(CDate(.Cells(CheckRow, 1).Value)) = yy_mm(CDate(Moji)) Then TopRow = CheckRow If TopRow = 1 Then .Rows(TopRow + 1 & ":" & EndRow).Rows.Group Exit Do End If Else .Rows(TopRow + 1 & ":" & EndRow).Rows.Group CheckRow = CheckRow + 1 Moji = "" End If CheckRow = CheckRow - 1 Loop Until CheckRow = 1 .Rows(CheckRow + 1 & ":" & EndRow).Rows.Group .Outline.ShowLevels RowLevels:=1 ExecuteExcel4Macro "SHOW.DETAIL(1," & CheckRow0 & ",TRUE)" End With End Sub Function yy_mm(d As Date) yy_mm = Format(d, "yy/mm") End Function
- 締切済み
- その他（プログラミング・開発）
- タイムスタンプを挿入して、時間の経過に合わせて色
Q列に同じ行のA列に文字が入ると、タイムスタンプを挿入して、時間の経過と共に、720時間かけて白から赤にグラデーション変化する。 上記のVBAを行いたいのですが、オーバーフローエラーが発生します。どの様に修正すれば良いでしょうか？ Private Sub Worksheet_Change(ByVal Target As Range) Dim currentDate As Date Dim startTime As Date Dim endTime As Date If Target.Column <> 1 Or Target.Cells.Count > 1 Then Exit Sub If Target.Offset(0, 15).Value = "" And Target.Value <> "" Then startTime = Now() Target.Offset(0, 15).Value = startTime ElseIf Target.Offset(0, 15).Value <> "" And Target.Value = "" Then endTime = Now() Target.Offset(0, 15).Value = "" End If currentDate = Now() If Target.Offset(0, 15).Value <> "" Then Target.Offset(0, 16).Interior.Color = GradientColor(Target.Offset(0, 15).Value, currentDate, startTime, 720) Else Target.Offset(0, 16).Interior.Color = RGB(255, 255, 255) End If End Sub Function GradientColor(ByVal timeStart As Date, ByVal timeEnd As Date, ByVal startTime As Date, ByVal duration As Integer) As Long Dim secondsElapsed As Long Dim fractionTimeElapsed As Double secondsElapsed = DateDiff("s", startTime, timeEnd) ➡︎ fractionTimeElapsed = secondsElapsed / (duration * 3600) fractionTimeElapsed = IIf(fractionTimeElapsed > 1, 1, fractionTimeElapsed) GradientColor = RGB(255 * (1 - fractionTimeElapsed), 255 * fractionTimeElapsed, 255 * fractionTimeElapsed) End Function
- ベストアンサー
- Visual Basic
お礼
ありがとうございます！ 非常に助かりました。 また宜しくお願いします。