• ベストアンサー
※ ChatGPTを利用し、要約された質問です（原文：シート状で同一の値のあるセルを一括変更するには）

シート状で同一の値のあるセルを一括変更する方法

HohoPapaの回答

  • HohoPapa
  • ベストアンサー率65% (454/690)
回答No.3

おそらくこの種の処理は、 レコードの順処理のほうがわかりやすく、コードも読みやすいと思います。 変更する会社コード：123 変更前会社名：山田商店 変更後会社名：海畑商店 請求書データベース 会社コード,注文日付、得意先名.... 123,2018/2/3,山田商店　　2行目 123,2018/2/4,森林商店　　3行目 456,2018/2/6,山田商店　　4行目 123,2018/2/7,海畑商店　　5行目 上記のデータの時 2行目は修正対象と思いますが 3,4,5行目は対象外にすればいいのか、 何らかの例外処理が必要なのか考える必要があるんじゃないかと思います。 また、修正するためのデータは、 ユーザフォームから取得してもいいんじゃないかと思います。 Sub DB_SH_Ment() 　 　Dim MentKey As String 　Dim OldName As String 　Dim NewName As String 　Dim RowCounter As Long 　Dim DBSH As Worksheet 　 　Set DBSH = ThisWorkbook.Sheets("請求書データベース") 　 　'更新データをシートから取得 　MentKey = DBSH.Cells(1, 48).Value　'AV 　OldName = DBSH.Cells(1, 46).Value　'AT 　NewName = DBSH.Cells(1, 47).Value　'AU '　'更新データをユーザフォームから取得 '　With UserForm1 '　　MentKey = .TextBox1.Text '　　OldName = .TextBox2.Text '　　NewName = .TextBox3.Text '　End With 　 　RowCounter = 2 　Do 　　 　　If DBSH.Cells(RowCounter, 1).Value = "" Then Exit Do 　　If ((DBSH.Cells(RowCounter, 1).Value = MentKey) And _ 　　　　(DBSH.Cells(RowCounter, 3).Value = OldName)) Then 　　　DBSH.Cells(RowCounter, 3).Value = NewName 　　End If 　　If ((DBSH.Cells(RowCounter, 1).Value = MentKey) And _ 　　　　(DBSH.Cells(RowCounter, 3).Value <> OldName)) Then 　　　'何らかの例外処理 　　End If 　　 　　RowCounter = RowCounter + 1 　Loop End Sub ※動作確認は一切行っていません。　　<m(__)m>

shibushijuko
質問者

お礼

ご回答いただき、誠にありがとうございます。 ユーザーフォームは変更したい行数を入力して、対象となる行の値をTextBoxに取得させるマクロを最初に実行させるように作りました。 以下がそのマクロ文です。　TextBox1は行番号、TextBox2は会社名、TextBox3以降は会社の住所や電話番号などの情報が入ります。 二つ目のマクロ文は変更前の会社名を同一シート上のZ1、変更後の会社名をZ3に取得させ、それぞれの値を「請求書データベース」AT1及びAT2が参照するようにしています。 理想的にはユーザーフォームから、すべて一括処理させることができればと思っています。ご教授いただいた内容で考えてみたいと思います。 Private Sub CommandButton3_Click() ActiveSheet.Unprotect Sheets("マスター").Range("D1").Value = TextBox1.Value If Range("D1") = "" Then MsgBox "何も入力されていません。", vbCritical ActiveSheet.Protect Else If IsNumeric(Range("D1").Value) = True Then ActiveSheet.Unprotect Dim i As Integer i = TextBox1.Value TextBox2.Value = Cells(i, 1) TextBox3.Value = Cells(i, 2) TextBox4.Value = Cells(i, 3) TextBox5.Value = Cells(i, 4) TextBox6.Value = Cells(i, 6) Range("Z2").Value = TextBox2.Value Range("Z3").Value = TextBox3.Value ActiveSheet.Protect MsgBox Range("D1") & "行目を表示しました。" & vbCrLf & "変更後(2)登録・変更ボタンを押してください。" ActiveSheet.Protect Else MsgBox "数値のみ入力してください。", vbCritical ActiveSheet.Protect End If End If End Sub Private Sub CommandButton3_Click() ActiveSheet.Unprotect Sheets("マスター").Range("D1").Value = TextBox1.Value If Range("D1") = "" Then MsgBox "何も入力されていません。", vbCritical ActiveSheet.Protect Else If IsNumeric(Range("D1").Value) = True Then ActiveSheet.Unprotect Dim i As Integer i = TextBox1.Value TextBox2.Value = Cells(i, 1) TextBox3.Value = Cells(i, 2) TextBox4.Value = Cells(i, 3) TextBox5.Value = Cells(i, 4) TextBox6.Value = Cells(i, 6) Range("Z2").Value = TextBox2.Value Range("Z3").Value = TextBox3.Value ActiveSheet.Protect MsgBox Range("D1") & "行目を表示しました。" & vbCrLf & "変更後(2)登録・変更ボタンを押してください。" ActiveSheet.Protect Else MsgBox "数値のみ入力してください。", vbCritical ActiveSheet.Protect End If End If End Sub

この回答がついた質問に戻る
回答 全件
ベストアンサー
>該当する得意先名の入ったセルをすべて選択して、 なぜ選択する必要が？…
訂正です。 Set fnd = .Columns("C").Find(…
  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. Visual Basic

関連するQ&A

  • エクセルのＶＢＡです。教えてください！

    ＩnputBoxで2重の検索をしたいのです。 1回目はＣ列、2回目はＤ列より入力されたデータを検索します。 両方のデータがあった行を指定した別の行へコピペしたいのですが・・・・。 この記述だとうまく作動しません。 どなたかわかる方お知恵を貸してください。 Sub test() Dim Keyword Dim Keyword2 Dim Fnd '入力されたキーワードを変数Keywordに入れる Keyword = InputBox("キーワードを入力してください") Keyword2 = InputBox("キーワード2を入力してください") '[既にあるデータの範囲]からキーワードを検索し、検索結果のセルをオブジェクト変数Fndにセットする Set Fnd = [既にあるデータの範囲].Find(Keyword) 'もし、キーワードが見つからなかったら If Fnd Is Nothing Or Fnd.Offset(, 1).Value <> Keyword2 Then MsgBox "データはありません" 'もし、キーワードが見つかったら Else 'キーワードが見つかったセルを含む行全体を、[別の指定した行]にコピペ Fnd.EntireRow.Copy [別の指定した行] End If End Sub

  • エクセルVBA、２重の検索方法について

    以前、回答していただいた記述で早速試してみたのですが・・・・。 実はキーワードの1つ目はデータの中に同じものがある場合があります。 1つ目で検索されたキーワードの同じものの中から、さらにキーワード２で最終的に絞り込みたいのです。 この記述だと、一番最初にキーワード１でひっかかったものしかキーワード２を検索しないので・・・。 Do　Loopを使うのだと思うのですが、どのように入れ込んでいくのかわかる方お願いします。 *この記述の内容は既にあるデータの中からInputBoxにキーワード１を入力し、データのC列を検索し１に合致したものの中から、さらにキーワード２で絞り込み、２つのキーワードが含まれた行全体を指定した場所にコピペするというものです。 Sub test02() 　　Dim Keyword, Keyword2, Fnd, Fnd2 　　'入力されたキーワードを変数Keywordに入れる 　　Keyword = InputBox("キーワードを入力してください") 　　Keyword2 = InputBox("キーワード2を入力してください") 　　'C列からキーワードを検索し、検索結果のセルをオブジェクト変数Fndにセットする 　　Set Fnd = Range("C:C").Find(Keyword) 'C列検索 　　If Not Fnd Is Nothing Then 'もし、C列にキーワードが見つかったら 　　　　Set Fnd2 = Range("E" & Fnd.Row).Resize(, 22).Find(Keyword2) '同行E-Z列検索 　　　　If Not Fnd2 Is Nothing Then 'もし、E～Z列にキーワードが見つかったら 　　　　　　Fnd.EntireRow.Copy 別の指定した行 'キーワードが見つかったセルを含む行全体を、[別の指定した行]にコピペ 　　　　　　Exit Sub '終了 　　　　End If 　　End If 　　MsgBox "データはありません" 'もし、キーワードが見つからなかったら End Sub

  • ワイルドカードを用いたセルの値加算&貼り付け

    こんにちは！ 下記動きを実現したく、他の質問で方々からご教示いただいた内容をヒントに 下記マクロを組んでみたのですが、実現したい動きになりませんでした。。 知識のある方がいらっしゃれば、間違いを指摘いただけると嬉しいです！ ＜実現したい動き＞ このファイルの貼り付け先シートのRange(Cells(6, 5), Cells(32, 30))に、 下記条件を満たす全ての値を加算のうえ、ペーストする。 「指定フォルダ」に格納されている、ファイル名に「あいう」を含むファイル(※)の、「指定シート」のRange(Cells(6, 5), Cells(32, 30))に存在する値 ※「あいう」の前後は不一致OK。複数存在し、ファイル数は可変。 ＜下記マクロを動かした結果＞ 該当ファイルは複数格納されているが、そのうちの1ファイルのみの値がコピペされている。 Sub マクロ() ' Dim folder As String Dim dws As Worksheet Dim sfile1 As String Dim swb1 As Workbook Dim adr As String Dim c As Integer folder = "C:\Users\指定フォルダ\" Set dws = ThisWorkbook.Worksheets("貼り付け先シート#1") Range(Cells(6, 5), Cells(32, 30))=0 sfile1 = Dir(folder & "*あいう*.xlsm") If sfile1 = "" Then Exit Sub Set swb1 = Workbooks.Open(folder & sfile1) adr = Range(Cells(6, 5), Cells(32, 30)).Address(0, 0, 1) swb1.Sheets("あいう").Range(adr).Copy dws.Range(adr).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd Application.CutCopyMode = False swb1.Close False End Sub

  • 値を変更後にセルがアクティブ状態に

    セルをダブルクリックして値を変えるマクロを作ったのですが 値を変更後にセルがアクティブ状態になってしまいます。 エンターを押したり他のセルをクリックすれば通常通りになるのですが、 ＶＢＡでも通常通りに戻すにはどうすればいいでしょうか？ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim mystr As String mystr = Target.Value If mystr = "Yes" Then Target.Value = "No" ElseIf mystr = "No" Then Target.Value = "Yes" End If End Sub を実行すると、 セルをクリックしてＦ２を押した時のような状態になってしまいます。 コードの最後に Target.Cells.Select を入れてみましたが、変わりませんでした。 スクショを撮ってみたのですが、カーソル？棒？が映りませんでした。

  • 【マクロ】特定シートから値を抽出し、別シートへ反映して印刷

    【マクロ】特定シートから値を抽出し、別シートへ反映して印刷 このようなマクロを組みたいです。 作成しましたがうまく動きません。 どなたか修正していただけませんか？ 【やりたいこと】 シート名1『データベース』 シート名2『通知書』 (1)『データベース』 　4行目からデータベースが作成された表 　C列は社員番号の列 ↓ (2)『データベース』シートのA列に『1』のフラグを立てる ↓ (3)『通知書』のセルB1に自動的に(2)で立てた行のC列の社員番号が反映され 　同時に通知書シートを印刷をする。 【組んでみたマクロ】 Dim i As Integer 'カウント用変数 Dim lastrow As Integer '最終行が入る変数 i = 4 '最初に始まる行数を指定 lastrow = ActiveSheet.Range("A65536").End(xlUp).Row '最終行を取得する For i = 4 To lastrow '最終行まで繰り返す If Worksheets("データベース").Range("A" & i & "") = 1 Then 'A列に「1」があったものは以下の処理をする '別シートの特定セルを取得する Worksheets("通知書").Range("B1") = "=INDIRECT(""データベース!""&""C" & i & """)" '社員番号 '印刷する Sheets("通知書").PrintOut Else 'A列に「1」がなかったら以下の処理をする End If 'A列に何かあるかの判別終了 Next i '繰り返しの終わり。i（カウント用変数）に１を足す End Sub

  • セルの値を別シートの月別合計リストに貼り付けるには

    一社の該当月の請求金額合計がシート名"請求書"のX42に入ってます。これを別のシート"請求書一覧表"の該当する会社の該当月に自動で貼り付けるVBAはありますでしょうか。シート名"請求書"には会社名がE10に、発行年月日がN3に入っています。 貼り付ける側のシート名”請求金額一覧表”のA列のA２から下に会社名が70社入っています。横列はB1からM1まで1月～12月の名前が入っています。今は、"請求書"シートの合計金額をコピーして、”請求金額一覧表”シートの該当する会社の該当月に貼り付けています。 これをVBAで自動処理できればと思っています。 この日付と会社名を使って条件分岐のVBAは可能でしょうか？ 今考えているのはN3に入っている発行年月日を、同じシート上で例えば =month(N3)で月だけ取得して、その月と会社名を取得して それを、請求金額一覧表”の特定のセルに貼り付ける事を考えました。Select Case やIf else if を使うと、マクロ分がとんでもなく長くなりそうです。やはり無理でしょうか？

  • Excel VBAで「セルが選択されたら…」

    任意の列のセルが選択されたら、マクロを実行したいんですが、どのようにしたらいいのでしょうか？ 「セルを変更したら…」っていうのはわかるんですが。。 Private Sub ***() Dim i As Integer i = ActiveCell.Row ***の部分がわかりません。 よろしくお願いします。

  • エクセルのセルの中の文字を一括・もしくは簡単に変更したい

    エクセルの列で、セルの中に「１」と「２」が入っています。 「１」を「男性」に、「２」を「女性」に、すべて変更する方法として、一番簡単な方法を教えてください。 エクセルの使い方、といったサイトを見てみたのですが、 どれに該当するのかよくわかりません。 １つ１つコピー＋貼り付けだと相当時間がかかります（＞＜”） たとえばＥ３のセルが「２」なので、そこに「女性」と入力して、 Ｅ４も「２」なので「=E3」と入れると確かに「女性」に換わりましたが、これでは結局１セルごとに作業していかなくてはなりません。 でもこんな方法しかないのなら、地道にやっていくしかないのかなぁ・・・と。 もしもっと簡単に変換出来るよ！という方法があれば、教えてください！

  • マクロセルの値によってセルの色を消す

    エクセル2013です。 セルの値が0又は空白の場合でそのセルが色塗りされていたら色を消す というマクロをを作成しました。 ただ700行55列では処理が遅いです。 Sub 色消() '成功 Dim 最終行 Dim 最終列 Dim 対象セル As Range 最終列 = Cells(8, Columns.Count).End(xlToLeft).Column '8行目の最終列を取得 最終行 = Cells(Rows.Count, 1).End(xlUp).Row 'A列の最終行を取得 For Each 対象セル In Range(Cells(10, 17), Cells(最終行, 最終列)) If 対象セル.Value = 0 Or 対象セル = "" Then 対象セル.Interior.ColorIndex = 0 End If Next 対象セル End Sub 対象範囲から対象セルを全部見つけて一括処理すれば早いのではと 以下のマクロを作成してみましたが Set 対象範囲 = Cells.Find(What:=0 Or "", LookIn:=xlValues, LookAt:=xlWhole) で構文ERRです。 どこを直せばいいのでしょうか？ よろしくお願いします。 Sub 色消2() '2014/8/4 '失敗 Dim 対象範囲 Dim 最終行 Dim 最終列 最終列 = Cells(8, Columns.Count).End(xlToLeft).Column '8行目の最終列を取得 最終行 = Cells(Rows.Count, 1).End(xlUp).Row 'A列の最終行を取得 対象範囲 = Range(Cells(10, 17), Cells(最終行, 最終列)) Set 対象範囲 = Cells.Find(What:=0 Or "", LookIn:=xlValues, LookAt:=xlWhole) If Not 対象範囲 Is Nothing Then 対象範囲.Interior.ColorIndex = 0 End If End Sub

  • vba:セル内変更文字列の色付け

    vbaにて別ブックの一覧を参照し、 指定範囲に検索文字列が含まれる場合 文字列の置換&対象セルの色付け& 件数の表示を行うコードから、 文字列の置換&セル内の変更した文字列のみ 色付け&件数の表示を行うコードに変更したいです。 変更した文字列のみ文字色を変更したい場合、 どのようなコードに書き換えればよろしいでしょうか。 なお、現在のコードは以下の通りです。 ============================ Sub 複数条件で一括置換する() Dim 範囲 As Object Dim 対象 As Object Dim 一覧 As Variant Set 範囲 = Selection 一覧 = Workbook("確認.xlsm").Sheets("複数条件").Range("A1:B7") Dim tmp As Variant Dim mCnt As Long 中略 mCnt = 0 For Each 対象 In 範囲 For i = LBound(一覧, 1) To UBound(一覧, 1) tmp = 対象.Value 対象.Value = Replace(対象.Value, 一覧(i, 1), 一覧(i, 2)) If tmp <> 対象.Value Then 対象.Interior.Color = vbRed mCnt = mCnt + 1 End If Next Next MsgBox mCnt & "件置換しました" Set 範囲 = Nothing Set 対象 = Nothing End Sub

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する
質問する