Excel VBAプログラムで学科の部分をマークする方法

このQ&Aのポイント
  • ExcelのVBAプログラムを使用して、特定の文字列が含まれるセルの一部をマークする方法を教えてください。
  • 質問のプログラムは、「鈴木」と書かれているセルをマークするものですが、学科の部分をマークするためにはどうすればよいか知りたいです。
  • 具体的には、学科の部分の文字列を特定してマークする方法を教えてください。
回答を見る
  • ベストアンサー

シート上に

シート上に A学科 相川 秋山・・・鈴木・・・ B学科 伊藤 ・・・鈴木 ・ ・ ・ と書いてあります。 Sub Find_01()  Dim c As Object  Dim myKey As String, fAddress As String    myKey = "鈴木"    With Worksheets(1).Range("a1:a30")       Set c = .Find(What:=myKey, LookIn:=xlValues, lookat:=xlWhole, _               SearchOrder:=xlByColumns, MatchByte:=False)      If Not c Is Nothing Then        fAddress = c.Address        Do          c.Interior.ColorIndex = 3          Set c = .FindNext(c)            If c.Address = fAddress Then Exit Do        Loop      End If    End With End Sub このプログラムで「鈴木」と書いてあるセルに色がつくのですが 「鈴木」という部分にはマークをせず、学科の部分をマーク するにはどうすればよいのでしょうか?

質問者が選んだベストアンサー

  • ベストアンサー
  • hige_082
  • ベストアンサー率50% (379/747)
回答No.1

>c.Interior.ColorIndex = 3 を cells(c.row,1).Interior.ColorIndex = 3 へ変更で良いと思うけど 参考まで

関連するQ&A

  • 指定先頭文字列の抽出と加工

    昨日からVBAに取り組んでいるVBA初心者です | B | 1|AABB| 2|BCBC| 3|BDBD| 4|AABC| 5|DEDE| この中から頭がAAのものに色をつけたいのですが どのようにしたらよいでしょうか? よろしくお願いします 単純にBBBBの文字列をB列から検索して色をつけるというのは 以下のようでやっていますが先頭文字を指定してそれに該当する 文字列の指定の仕方がわかりません。 どうかよろしくご教授のほどお願いします Sub testsub() Dim c As Object Dim myKey As String, fAddress As String myKey = "BBBB" With ActiveSheet.Range("b:b") Set c = .Find(What:=myKey, LookIn:=xlValues, lookat:=xlWhole, _ SearchOrder:=xlByColumns, MatchByte:=False) If Not c Is Nothing Then fAddress = c.Address Do c.Interior.ColorIndex = 1 '背景 赤 c.Characters.Font.Color = vbWhite '文字 白 c.Characters.Font.Bold = True '太字 Set c = .FindNext(c) If c.Address = fAddress Then Exit Do Loop End If End With ' End Sub

  • VBA エクセル 文字列

    A列に、【鈴木 太郎】、【佐藤 一郎】・・・・と続いていて、B列には鈴木、佐藤・・・と表示させたい場合は以下のソースに、 =LEFT(A1,FIND(" ",SUBSTITUTE(A1," "," "))-1) と同じソースを書けばいいのはわかるのですが、勉強不足でわかりません。教えていただけませんでしょうか。下記のソースも教えていただきました。すごく助かります。 Sub PickupWords() Dim Matches As Object Dim Match As Object Dim buf As String Dim c As Variant With CreateObject("VBScript.RegExp") .Pattern = "【(.+)】" .Global = False Application.ScreenUpdating = False For Each c In Range("A1", Cells(Rows.Count, 1).End(xlUp)) If .Test(c.Value) Then buf = c.Value Set Matches = .Execute(buf) c.Offset(, 1).Value = Matches.Item(0).SubMatches(0) '括弧の中を取り出す End If Next c Application.ScreenUpdating = True End With End Sub

  • どなたか教えてください。

    Public myop As Integer 'オプション選択保持用 Private Sub CommandButton1_Click() Dim row As Integer Dim mykey As String '比較キー '選択したオプションボタンにより '比較キーと選択保持用変数に各値を代入 Select Case True Case OptionButton3: mykey = ("A2:A11"): myop = 1 Case OptionButton4: mykey = ("B2:B11"): myop = 2 Case OptionButton5: mykey = ("C2:C11"): myop = 3 Case OptionButton6: mykey = ("D2:D11"): myop = 4 Case Else: myop = 0 End Select If myop = 0 Then Exit Sub For row = 1 To 65535 If ActiveSheet.Cells(1, row).Value Like mykey Then ActiveSheet.Cells(1, row) = "#####" End If Next row End Sub で、For row = 1 To 65535でエラーがでます。 どうしてなのでしょうか・・・?

  • エクセルVBAのFINDの質問です。

    エクセルVBAのFINDの質問です。 シート1    A    B    C     D 1 コード1 コード2 コード3 名 称 2  4    1     1 3  4    2     2 4  4    3     1 シート2    A    B 1 コード1 名 称 2  1   名称1 3  2   名称2 やりたいことは、シート1のD列に、シート1のコード3をもとにシート2から名称を取得したいのです。 下記に記したプログラムだと最初のFINDNEXTは動くのですが、 2回目でエラーになってしまい、次を読んでくれません。 どなたか、ご教授頂けますでしょうか。 シート1の検索条件はコード1の"4"です。 シート1のコード1は重複キーで、一レコードずつ読んで行き、各レコード毎にシート2を読みたい のです。 Dim シート1 As Worksheet Dim シート2 As Worksheet Dim obj As Object Dim Lin As Integer Dim mykey As Integer Dim obj1 As Object Dim Lin1 As Integer Dim mykey1 As Integer Dim st_Lin As Integer Set シート1 = ThisWorkbook.Worksheets("シート1") Lin = シート1.Cells(シート1.Rows.Count, 1).End(xlUp).Row mykey = "4" Set obj = シート1.Range("A1", "A" & Lin).Cells.Find(What:=mykey, _ LookIn:=xlValues, _ lookat:=xlWhole, _ SearchOrder:=xlByColumns) If obj Is Nothing Then   MsgBox ("異常です")   Exit Sub Else   st_Lin = obj.Row   Do Until obj.Row <> st_Lin    Set obj = シート1.Range("A1", "A" & Lin).FindNext(obj)    If obj Is Nothing Then     Exit Do    Else     Set シート2 = ThisWorkbook.Worksheets("シート2")       With シート2          Lin1 = .Cells(シート2.Rows.Count, 1).End(xlUp).Row          mykey1 = シート1.Cells(obj.Row, 3).Value          Set obj1 = .Range("A1", "A" & Lin1).Cells.Find          (What:=mykey1,LookIn:=xlValues,lookat:=xlWhole,SearchOrder:=xlByColumns)          If obj1 Is Nothing Then           MsgBox ("名称取得できませんでした")           Exit Sub          Else            シート1.Cells(obj.Row, 4).Value = .Cells(obj1.Row, 2).Value          End If       End With    End If   Loop End If

  • 複数のエクセルシートをまとめるマクロ

    下は複数のエクセルファイルを一つにするマクロですが、100万件を超えるためcsvで保存するようにするにはどこを変更したらよいでしょうか。 よろしくお願いします。 Sub Sample() Dim t As Single Dim strPath As String Dim strFileName As String Dim WB1 As Workbook Dim WS1 As Worksheet Dim WS2 As Worksheet Dim lngRowCount As Long 'A列に値が入っているデータ数 t = Timer 'まとめたいシート Set WS2 = ThisWorkbook.Worksheets(1) strPath = ThisWorkbook.Path strFileName = Dir(strPath & "\*.xls*") Do While strFileName <> "" If strFileName <> ThisWorkbook.Name Then Set WB1 = Workbooks.Open(strPath & "\" & strFileName) Set WS1 = WB1.Worksheets(1) With WS1.Range("A1") lngRowCount = .Worksheet.Cells(.Worksheet.Rows.Count, .Column).End(xlUp).Row - .Row If lngRowCount >= 1 Then With .Resize(lngRowCount, 14).Offset(1) .Copy WS2.Range("A" & WS2.Rows.Count).End(xlUp).Offset(1) End With End If End With WB1.Close False End If strFileName = Dir Loop MsgBox "まとめ処理をしました。処理時間 " & Format((Timer - t) / 60 / 60 / 24, "h:mm:ss") End Sub

  • 「:」を使えば、一行のコードにできるわけではない?

    「:」を使えば、一行のコードにできるわけではないのですか? ifステートメントを1行にしたいのですが Sub test() Dim a As String a = "aiu" If a Like "*i*" Then: Stop: End If End Sub これだと End If に対応する If ブロックがありません。 となってしまいます。 ちゃんと、 Sub test() Dim a As String a = "aiu" If a Like "*i*" Then Stop End If End Sub こうしないとダメですか? なぜ、:は使えないのですか? よろしくお願いします。

  • EXCEL 2つの特定の文字列がある行を残して削除

    EXCELにて2つの特定の文字列が含まれる行を残して削除したいと思っております。 A列50行にそれぞれ"年賀状""喪中""名刺"がランダムに羅列されていて、その中から"年賀状"と"喪中"の行だけを残して"名刺"の行は削除したいと思ってます。(B列以降は注文番号、枚数、氏名等が入力されています) 以下のコードで1つだけは可能でしたが、色々試しても2つはできませんでした。(コードは拾い物を少しアレンジ) Sub MacroTest1()   Dim keyWord As Variant   Dim FirstAdd As String   Dim UR As Range   Dim c As Range   Const col As Long = 1 '列数   keyWord = "年賀状"   If VarType(keyWord) = vbBoolean Or Len(keyWord) = 0 Then Exit Sub      With ActiveSheet     With .UsedRange       Set c = .Find( _       What:="*" & keyWord & "*", _       LookIn:=xlValues, _       LookAt:=xlPart, _       SearchOrder:=xlByRows)              If Not c Is Nothing Then         FirstAdd = c.Address         Set UR = c         Do           Set c = .FindNext(c)           Set UR = Union(UR, c)           If c.Address = FirstAdd Then Exit Do         Loop Until c Is Nothing       End If     End With     If Not UR Is Nothing Then       UR.EntireRow.Hidden = True       .UsedRange.SpecialCells(xlCellTypeVisible).Delete       .UsedRange.EntireRow.Hidden = False     End If   End With End Sub どうか宜しくお願いします。

  • サンプルプログラムでエラーが出てしまいます、対処法を教えて下さい。

    Sub test写真の連続挿入()   Dim myDir As String   Dim myFile As String   Dim i As Integer   Dim n As Integer   n = 10   myDir = "D:\写真\" myFile = Dir(myDir, vbNormal)   Application.ScreenUpdating = False   Do Until myFile = ""   If myFile <> "." And myFile <> ".." Then   If (GetAttr(myDir & myFile) And 16) <> 16 Then   i = i + 1   With ActiveSheet.OLEObjects("Image" & i)    .Object.PictureSizeMode = 3    .Object.Picture = LoadPicture(myDir &myFile)   End With   If i = n Then Exit Do   End If   End If   myFile = Dir   Loop   Application.ScreenUpdating = True End Sub このWith ActiveSheet.OLEObjects("Image" & i)の行でエラーが出てしまいます、対処法を教えて下さい。( 実行時エラー'1004'OLEObjects プロパティを取得できません)

  • VBAにてアクティブでは無いシートの値が参照されてしまいます。

    こんばんは、以前二回程質問させていただいた物です。 過去のアドバイスから少しずつ疑問をつぶしていった所再び問題が発生してしまいました。 同じプログラムを何度も載せるのは大変恐縮ですが、どうしても解決出来ない為(私の努力不足は重々承知です)皆様の力を貸して頂きたいと思います。 以下のようなループの際、途中にMsgBox(strFILENAME)を入れたり、Active.sheetでウオッチ式で見ても参照してほしいシート名を表示するにも関わらず、計算結果を書き込むシートのセルを参照してしまいます。 なぜ、WS1のセルの値を参照してしまうのかわからず困っています。 確実にMsgBox(strFILENAME)で表示されるファイル名のシートのセルを参照する方法を教えて頂きたく、よろしくお願いいたします。(Workbook.Worksheet.のように明示する方法を教えていただいたのですがエラーが発生してしまいうまく使いこなすことが出来ませんでした) どうか、宜しくお願いいたします。 Option Explicit Sub syoutotumen() Dim i As Long Dim j As Long Dim k As Long Dim kyori As Long Dim n As Integer n = 1 i = 1 j = 1 k = 1 Const cnsYEN = "\" Dim swESC As Boolean Dim ws1 As Worksheet Dim xlAPP As Application Dim objWBK As Workbook Dim strPATHNAME As String Dim strFILENAME As String strPATHNAME = "C:\Documents and Settings\tata41\デスクトップ\画像処理2\" If strPATHNAME = "" Then Exit Sub strFILENAME = Dir(strPATHNAME & "demo******", vbNormal) If strFILENAME = "" Then MsgBox "このフォルダにはExcelワークブックは存在しません" Exit Sub End If Set xlAPP = Application With xlAPP .ScreenUpdating = False .EnableEvents = False .EnableCancelKey = xlErrorHandler .Cursor = xlWait End With Set ws1 = Worksheets("sheet1") Range("A1") = "0" Range("A2") = "1" Range("A1:A2").Select Selection.AutoFill Destination:=Range("A1:A1022") Do While strFILENAME <> "" DoEvents If swESC = True Then If MsgBox("ESCが押されました。ここで終了しますか?", vbInformation + vbYesNo) = vbYes Then GoTo Button1_Click_Exit Else swESC = False End If End If xlAPP.StatusBar = strFILENAME & "処理中・・・" Set objWBK = Workbooks.Open(Filename:=strPATHNAME & cnsYEN & strFILENAME, UpdateLinks:=False, ReadOnly:=True) Do If Cells(i, 2) = 0 Then Exit Do i = i + 1 Loop Do If Cells(j, 3) = 0 Then Exit Do j = j + 1 Loop Do If Cells(k, 4) = 0 Then Exit Do k = k + 1 Loop kyori = (i + j + k - 21) / 3 ws1.Cells(n, 2) = kyori n = n + 1 i = 1 j = 1 k = 1 objWBK.Close savechanges:=False strFILENAME = Dir Loop GoTo Button1_Click_Exit Button1_Click_ESC: If Err.Number = 18 Then swESC = True Resume ElseIf Err.Number = 1004 Then Resume Next Else MsgBox Err.Description End If Button1_Click_Exit: With xlAPP .StatusBar = False .ScreenUpdating = True .EnableEvents = True .EnableCancelKey = xlInterrupt .Cursur = xlDefault Set objWBK = Nothing Set xlAPP = Nothing End With End Sub

  • VBAにてリストボックスで選択すると別ブックにあるデータを個別の窓へ表示させるには?

    はじめまして、ゴールデンウィーク中にVBAを勉強していますが、上手くいきません。内容は、「UserForm1を使って別シートにあるデーターから検索を行い、ListBox1に抽出されたリストを選択すると個別のTextBox2に関連する詳細を表示させる」というものです。別シートには「顧客データ」があり、A列より「担当、氏名、カタナカ、住所、電話番号・・・」とデーターが並んでいます。中途半端な状態ですが、これ以上進めません。だれか助けてください。 Private Sub CommandButton1_Click() Dim Namae As String Dim MeNamae As Object Dim ken As String Namae = TextBox1.Text Set MeNamae = UserForm1 Call 検索(Namae, MeNamae) End Sub '受付画面に検索画面窓を出し、顧客データから検索した結果を出すマクロ Public Sub 検索(ByVal Namae As String, ByRef MeNamae As Object) Dim Nagasa As Integer Dim i As Long Dim MaxRows As Long Dim kensaku As Object Dim KensakuChar As String Dim ListNamae As String Dim ListChar As String Dim KBanme As Integer Dim LBanme As Integer Set kensaku = Worksheets("顧客データ") MaxRows = kensaku.UsedRange.Rows.Count Nagasa = Len(Namae) MeNamae.ListBox1.Clear For i = 3 To MaxRows ListNamae = kensaku.Cells(i, 3) KBanme = 0 LBanme = 0 Do Do While Nagasa >= KBanme KBanme = KBanme + 1 KensakuChar = Mid(Namae, KBanme, 1) If KensakuChar <> " " Then Exit Do End If Loop Do While Nagasa >= LBanme LBanme = LBanme + 1 ListChar = Mid(ListNamae, LBanme, 1) If ListChar <> " " Then Exit Do End If Loop If KensakuChar = ListChar Then If Nagasa = KBanme Then With MeNamae .ListBox1.AddItem (ListNamae) End With End If Else Exit Do End If Loop Until Nagasa <= KBanme Next End Sub Private Sub ListBox1_Click() With ListBox1 If .ListIndex > -1 Then TextBox2.Value = .List(.ListIndex, 0)’←これでは何の意味も無い ' TextBox2.Value = kensaku.Cells(kensakuIndex, 3) ' TextBox2.Value = kensaku.Cells(kensaku, 3) ' TextBox2.Text = kokyaku.Hoken4 '      TextBox2.Text = kokyaku.Cells(i, 5) End If End With End Sub