Excel VBA セル選択
- Excel VBAのコードを使用して、選択した範囲内の全てのセルを変換する方法を教えてください。
- ExcelのVBAを使用して、選択した範囲内の複数のセルを一括で変換する方法を教えてください。
- ExcelのVBAを活用して、複数のセルを選択し、全角を半角に一括変換する方法を教えてください。
- ベストアンサー
Excel VBA セル選択
Sub 全角() Dim i As Long, buf As String For i = 1 To Len(ActiveCell.Value) If Mid(ActiveCell.Value, i, 1) Like "[ア-ン]" Then buf = buf & StrConv(Mid(ActiveCell.Value, i, 1), vbWide) Else buf = buf & Mid(ActiveCell.Value, i, 1) End If Next i ActiveCell.Value = buf End Sub このコードだと一つのセルしか変換できません。 選択した範囲全部を変換できるようにしたいです。
- meronsodanomu
- お礼率95% (210/220)
- Excel（エクセル）
- 回答数1
- ありがとう数3
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
以下のようにして下さい。 Sub 全角() Dim i As Long, buf As String Dim ac As Range For Each ac In Selection buf = "" For i = 1 To Len(ac.Value) If Mid(ac.Value, i, 1) Like "[ア-ン]" Then buf = buf & StrConv(Mid(ac.Value, i, 1), vbWide) Else buf = buf & Mid(ac.Value, i, 1) End If Next i ac.Value = buf Next ac End Sub プログラム内の「ア」と「ン」は半角カナに直して下さい。このサイトは半角カナを書くと勝手に全角カナに書き換えてしまいます（貴方の質問文も、勝手に全角カナに直されてしまっています）
関連するQ&A
- 【VBA】セルの中身を日付形式に変換したい
w列のセルの中に20140701のように入っているセルを2014/07/01に変換するマクロを作っております。 それで以下のように書いてみたのですが、「型が一致しません」と出てしまい、先に進めずにおります…。お力借りられますと幸いです。 Dim org As String Dim buf As String Dim i As Long i = 1 Do Until Cells("w", i) = "" Cells("w", i).Select With ActiveCell org = .Value If Len(org) = 8 Then buf = _ Mid(org, 1, 4) & "/" & _ Mid(org, 5, 2) & "/" & _ Mid(org, 7, 2) If IsDate(buf) = True Then .Value = buf .NumberFormatLocal = "yyyy年m月d日" End If End If End With i = i + 1 Loop
- 締切済み
- Excel（エクセル）
- エクセルvba カタカナは全角、それ以外は半角に
セルにはカタカナ、数字、漢字、文字がすべて混在しています。 カタカナは全角に、カタカナ以外（数字や記号）は半角に統一しようかと思っています。 一度すべてを半角にし、カタカナだけ全角に戻そうかと考えました。 Sub test() Dim e As Range Dim f As Integer Dim rData As Variant, ansData As Variant Range("A1:A10").Select For Each e In Selection ansData = "" For f = 1 To Len(e.Value) rData = StrConv(e.Value, vbNarrow) If Mid(rData, f, 1) Like "[ア-ン]" Then ansData = ansData & StrConv(Mid(rData, f, 1), vbWide) Else ansData = ansData & Mid(rData, f, 1) End If Next f e.Value = ansData Next e End Sub しかしこれでは、 「ッ」「ァ」など小さい文字や、「ー（長音）」が半角から全角に戻りません。 また、「ズ」など濁音が「ス゛」と２文字になってしまいます。 これらの正しく変換されないものをすべて列挙し、Replaceなどを使って修正するしかないのでしょうか？ 実は最初に、すべてを「全角→半角」にするようマクロ作成したのですが、半角にする文字をReplaceですべて列挙しるのは大変だと思い、「半角→全角」にしたらうまくいくかと思ったのですが、それでもうまくいきませんでした・・・ よろしくお願いします。
- ベストアンサー
- その他MS Office製品
- \はエクセルでは全角？
半角文字の\はエクセル（ＶＢＡ）では全角扱いなのでしょうか？ 添付のマクロを実行すると結果は"全角だろう"になります。 \はStrConvでvbWideを指定しても全角になりません。 全角の￥はStrConv/vbNarrowで半角になります。 どういう理由でこうなっているのでしょうか？ \以外にもこのような文字があるのでしょうか？ ご存知の方、教えていただけないでしょうか。 Sub Macro1() ch1 = "\" ch2 = StrConv(ch1, vbWide) If ch1 = ch2 Then Debug.Print "全角だろう" Else Debug.Print "半角だろう" End If End Sub
- ベストアンサー
- オフィス系ソフト
- Excel2010 VBA 条件色付け
Sub sample() Dim r As Range For Each r In Range("q6:q30") If myIsNumeric(r) Then r.Offset(0, 1).Value = "数字" Else r.Offset(0, 1).Value = "文字" End If Next End Sub Function myIsNumeric(Target As Range) Dim r As Range Dim buf, tmp Dim flg As Boolean Dim i As Integer buf = Target For i = 1 To Len(buf) tmp = Mid(buf, i, 1) If IsNumeric(tmp) Then flg = True Exit For End If Next myIsNumeric = flg End Function を数字が入ってたら塗りつぶさないで、 数字が入ってなかったら塗りつぶすように直したいです。 あああ→塗る あああ1－1→塗らない 住所→塗る 住所12→塗らない
- ベストアンサー
- Excel（エクセル）
- EXCELで作ったマクロを別のファイルのEXCELでも使えるようにしたいです。
(1)EXCELファイルでマクロを作成しました。 (実際はここである人の知恵をお借りして作ったものですが…) しかし、(2)EXCELファイルで(1)EXCEL作成マクロが実行できません。 どのような処理をすれば、どのPCでも、どのファイルでも実行できるようなマクロに出来るのでしょうか？？ 以下にそのマクロを示します。 ↓↓↓ Sub 文字置換() '半角カタカナを全角に、全角英数を半角にするマクロ (Excel編） Dim rng As Range Dim Re As Object Dim myPat As String Dim c As Range Dim Matches As Object Dim Match As Object Dim Str1 As String Dim Str2 As String Dim buf As String Dim t As Long On Error Resume Next Set rng = ActiveSheet.UsedRange.SpecialCells _ (xlCellTypeConstants, xlTextValues) On Error GoTo 0 If rng Is Nothing Then MsgBox "変換する対象が見当たりません。", 48 Exit Sub End If '全角側 --- 半角側 (！-／ を加えれば記号も半角) myPat = "([\uFF66-\uFF9F]*)([！-｝]*)" '正規表現のパターン Set Re = CreateObject("VBScript.RegExp") Application.ScreenUpdating = False With Re .Global = True .IgnoreCase = True .Pattern = myPat For Each c In rng.Cells Set Matches = .Execute(c.Value) If Matches.Count > 0 Then buf = c.Value For Each Match In Matches If Len(Match.Value) > 0 Then Str1 = StrConv(Match.SubMatches(0), vbWide) If Str1 <> "" Then '0 =vbBinaryCompare buf = Replace(buf, Match.SubMatches(0), Str1, , , 0) End If Str2 = StrConv(Match.SubMatches(1), vbNarrow) If Str2 <> "" Then buf = Replace(buf, Match.SubMatches(1), Str2, , , 0) End If End If Str1 = "": Str2 = "" Next Match If buf <> c.Value Then c.Value = buf t = t + 1 End If End If Next c End With Set Re = Nothing Application.ScreenUpdating = True If t > 0 Then MsgBox t & "個のセルを変換しました。", 64 End If End Sub 出来れば、置換した文字数をメッセージBOXに表示したいです。
- 締切済み
- オフィス系ソフト
- Excel VBAフォーム 登録ボタンの作成方法
いつもお世話になっています。 初めて、Excelのフォームで入力画面を作りました。 複数の項目があって、それを最後に[登録]ボタンをクリックで 表に入れたいのですが、一度にまとめて実行する方法が分かりません。 アドバイスよろしくお願いいたします。 Private Sub cmd_1() Dim i As String If man.Value = True Then ActiveCell = man.Caption End If If woman.Value = True Then ActiveCell = woman.Caption End If ActiveCell.Offset(0, 1).Select End Sub Private Sub cmd_2() Dim i As String If man.Value = True Then ActiveCell = Yes.Caption End If If woman.Value = True Then ActiveCell = No.Caption End If ActiveCell.Offset(0, 1).Select End Sub Private Sub cmd_downlist() Dim ListNo As Long ListNo = group.ListIndex ActiveCell.Value = group.List(ListNo, i) ActiveCell.Offset(0, 1).Select End Sub Private Sub cmd_comment() ActiveCell = comment.Text ActiveCell.Offset(1, -3).Select End Sub
- 締切済み
- Visual Basic
- エクセルＶＢＡのコードを簡単に表現したい
お世話になっています。 エクセルＶＢＡでコードを書いたのですが、なにぶん初心者のためゴテゴテしたものになってしまいました。 Ａ列にはＡ2からＡ11まで１５文字以内の文字列が入っています。 同じ行のＢ列からＰ列に、濁点も１文字として１セルに１文字づつ抜き出すようにコードを書きました。 以下です。 Sub test() Dim i As Integer Dim m As Integer Dim s1 As Worksheet Set s1 = Sheets("sheet1") For i = 2 To 11 For m = 1 To 15 変換 = s1.Cells(i, 1) 変換 = StrConv(変換, vbKatakana) 変換 = Application.WorksheetFunction.Asc(変換) 変換 = Mid(変換, m, 1) 変換 = StrConv(変換, vbWide) s1.Cells(i, m + 1) = StrConv(変換, vbHiragana) Next Next End Sub そこで質問なのですが、上記のコードをもっとスマートに表現するとどのようなコードになるのでしょうか。（特に「変換」が連なっているところ） よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- エクセルファイル 行列入れ替えたもの同時作成VBA
あるxmlファイルを一旦テキストファイルにして そこから数値をエクセルファイルに移行して ひとつはM.xlsxとし それに続いて行列を入れ替えた エクセルファイルR.xlsxを 作りたいのですが M.xlsx R.xlsxのそれぞれを作るコードを 単純に 合体させただけでは どうも できません M.xlsxだけ また R.xlsxだけの 作成するコードは 出来たのですが それぞれ別のマクロとして実行することになります ひとつのマクロでM.xlsx R.xlsx同時に 作成するVBAコードは可能でしょうか 宜しくお願い致します ちなみに該当コードを単純化して 合体したのが以下のものです win10 office10 Sub 783縦() Dim FileName As Variant ChDir "\\DESKTOP-O5\f" FileName = Application.GetOpenFilename(FileFilter:="xmlファイル,*.xml") If FileName = False Then MsgBox "キャンセルされました" Exit Sub End If FileCopy FileName, Left(FileName, InStrRev(FileName, "\")) & "テキスト.txt" Const MyFile = "\\DESKTOP-O5\f\テキスト.txt" Const Key1 = "<Name>" Const Key2 = "</Name>" Const Key3 = "<NameKana>" Const Key4 = "</NameKana>" Const PutBokName = "M.xlsx" Dim buf As String Dim Len1 As Long Dim Len2 As Long Dim Pos1 As Long Dim Pos2 As Long Dim Len3 As Long Dim Len4 As Long Dim Pos3 As Long Dim Pos4 As Long Dim PutBook As Workbook With CreateObject("ADODB.Stream") .Charset = "UTF-8" .Open .LoadFromFile MyFile buf = .ReadText .Close End With Len1 = Len(Key1) Len2 = Len(Key2) Pos1 = InStr(buf, Key1) Pos2 = InStr(buf, Key2) Len3 = Len(Key3) Len4 = Len(Key4) Pos3 = InStr(buf, Key3) Pos4 = InStr(buf, Key4) Set PutBook = Workbooks.Add With PutBook.Sheets(1) .Cells(1, 1).Value = "氏名" .Cells(1, 2).Value = Mid(buf, Pos1 + Len1, Pos2 - (Pos1 + Len1)) .Cells(2, 1).Value = "氏名カナ" .Cells(2, 2).Value = Mid(buf, Pos3 + Len3, Pos4 - (Pos3 + Len3)) 'クリップボードをクリア Application.CutCopyMode = False PutBook.SaveAs ThisWorkbook.Path & "\" & PutBokName End With Const PutBokName = "R.xlsx" Dim buf As String Dim Len1 As Long Dim Len2 As Long Dim Pos1 As Long Dim Pos2 As Long Dim Len3 As Long Dim Len4 As Long Dim Pos3 As Long Dim Pos4 As Long Dim PutBook As Workbook With CreateObject("ADODB.Stream") .Charset = "UTF-8" .Open .LoadFromFile MyFile buf = .ReadText .Close End With Len1 = Len(Key1) Len2 = Len(Key2) Pos1 = InStr(buf, Key1) Pos2 = InStr(buf, Key2) Len3 = Len(Key3) Len4 = Len(Key4) Pos3 = InStr(buf, Key3) Pos4 = InStr(buf, Key4) Set PutBook = Workbooks.Add With PutBook.Sheets(1) .Cells(1, 1).Value = "氏名" .Cells(2, 1).Value = Mid(buf, Pos1 + Len1, Pos2 - (Pos1 + Len1)) .Cells(1, 2).Value = "氏名カナ" .Cells(2, 2).Value = Mid(buf, Pos3 + Len3, Pos4 - (Pos3 + Len3)) 'クリップボードをクリア Application.CutCopyMode = False PutBook.SaveAs ThisWorkbook.Path & "\" & PutBokName End With End Sub -------------------------------
- 締切済み
- その他（プログラミング・開発）
- エクセルVBAで無限ループ
教えてください。 以下の２つのエクセルマクロはまったく同じことをさせようとしているのですが、test02の方は.Offset(1).Activateが働かないのか、無限ループに陥ってしまいます。 単にActiveCell.という記述をWith～End Withでまとめただけなのになぜこうなるのでしょうか？ Sub test01() ActiveSheet.Cells(1, 1).Activate Do While ActiveCell.Value <> "" If Not IsNumeric(ActiveCell.Value) Then ActiveCell.Offset(0, 1).Value = "文字" ElseIf ActiveCell.Value > 0 Then ActiveCell.Offset(0, 1).Value = "正数" ElseIf ActiveCell.Value < 0 Then ActiveCell.Offset(0, 1).Value = "負数" Else ActiveCell.Offset(0, 1).Value = "その他" End If ActiveCell.Offset(1).Activate i = i + 1 Application.StatusBar = i Loop End Sub Sub test02() ActiveSheet.Cells(1, 1).Activate With ActiveCell Do While .Value <> "" If Not IsNumeric(.Value) Then .Offset(0, 1).Value = "文字" ElseIf .Value > 0 Then .Offset(0, 1).Value = "正数" ElseIf ActiveCell.Value < 0 Then .Offset(0, 1).Value = "負数" Else .Offset(0, 1).Value = "その他" End If .Offset(1).Activate i = i + 1 Application.StatusBar = i Loop End With End Sub
- ベストアンサー
- オフィス系ソフト
- 検索後のセルの選択を正しくしたい
Excel2007でマクロ作成中の初心者です。 以下のコードの中で(1)のところがうまく作動できません。 ここの ActiveCell.Select を正常にするにはどうしたらよいかご教示をお願いします。 Sub 最終日の検索() Dim FC As Range Dim mydate As Date mydate = Range("BQ5").Value For Each FC In Range("BR30:BR300") If FC.Value = DateValue(mydate) Then Exit For End If Next If FC Is Nothing Then MsgBox "みつかりませんここでおわりです" Exit Sub End If MsgBox "見つかりました" & vbLf & FC.Address(0, 0) & vbLf & FC.Value ' ' ここに処理を追加したい ActiveCell.Select ’----------(1) Selection.Offset(0, 45).Select ActiveCell.Select 貼付けしてあるかどうか Set FC = Nothing End Sub ---------------------------------- Sub 貼付けしてあるかどうか() If ActiveCell.Value = "※※" Then MsgBox " 既に貼付けしてあります" Else MsgBox "貼付けしてないので処理します" End If End Sub
- ベストアンサー
- Visual Basic
お礼
ありがとうございます。 やりたかったことが出来ました。