VBAで英字が先頭にある場合に特定の文字を挿入するマクロ
- VBAを使用してExcelの特定の列に英字が先頭にある場合、定型の文字を先頭に挿入するマクロを作成したい。しかし、作成したマクロがうまく機能していないため、修正方法を教えて欲しい。
- 質問者は、Excelの特定の列に英字が入っている場合に、「ン」を先頭に挿入するマクロを作成している。しかし、このマクロが正常に動作していないため、どこが間違っているのかと、正しい書き方を教えて欲しいと質問している。
- Excelの特定の列に英字が入っている場合に、「ン」を先頭に挿入するVBAのマクロを作成しているが、うまく動作していない。修正方法を教えて欲しいと質問している。
- ベストアンサー
VBA １文字目が英字なら、先頭に文字を挿入する
ＯＳはＸＰ Ｅｘｃｅｌは2003を使用しています。 Ｃ列のセルに「ABC」や「DEF」など英字が入っている場合のみ、 「ンABC」や「ンDEF」の様に、先頭にカタカナの半角ンを入れるマクロを組みたいと思い、 似たようなサンプルマクロを参考にしながら下記を作ってみましたが、 希望通りには出来ません。 Dim d As Long Dim i As Long Dim f As String d = Range("A1").CurrentRegion.Rows.Count For i = 2 To d f = Cells(i, "C") If Left(f, 1) Like "[A-z]" = True Then f = "ン" & f End If Next i どなたか間違えているところと、どう書き直せばいいのか教えて頂けるとと助かります。 説明不足なところは追記致しますので、教えて下さい。 よろしくお願い致します。
- 6338-tm
- お礼率95% (89/93)
- オフィス系ソフト
- 回答数1
- ありがとう数1
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
文字の先頭が英字かどうかで判断するのであれば、 f = "ン" & f を Cells(i, "C") = "ン" & f に変更
関連するQ&A
- エクセルVBAについて
前回質問させていただきました件の追加機能になります。以前質問させていただきましたマクロが下記のものです。 Sub TESTa() Dim A As Long Dim B As Long Dim C As Long Dim D As Long Dim E As Long Dim F As Long '表の行数を調べる A = Worksheets("sheet1").Range("C65536").End(xlUp).Row - 1 For C = 1 To A For B = 4 To 7 'Sheet1のデータをSheet2に複写する Worksheets("Sheet2").Cells(B - 3 + D, 15) = Worksheets("Sheet1").Cells(C + 1, 1) Worksheets("Sheet2").Cells(B - 3 + D, 6) = Worksheets("Sheet1").Cells(C + 1, B) Worksheets("Sheet2").Cells(B - 3 + D, 14) = Worksheets("Sheet1").Cells(C + 1, 3) Worksheets("Sheet2").Cells(B - 3 + D, 10) = Worksheets("Sheet1").Cells(1, B) Worksheets("Sheet2").Cells(B - 3 + D, 13) = Worksheets("Sheet1").Cells(C + 1, 2) Next D = C * 4 Next 'Sheet2の表の行数を調べる Sheets("Sheet2").Select E = Worksheets("sheet2").Range("F65536").End(xlUp).Row '0欄の確認 For F = E To 1 Step -1 If Worksheets("Sheet2").Cells(F, 6) = 0 Then '0の場合は行を削除する Cells(F, 1).EntireRow.Delete End If Next End Sub カウントするとデータ個数がSheet1で約１２０件になりSheet2においては、４倍になりますので約４８０件になります。 そこで Sheet1において１２件ごとに、Sheet2,3,4...としたいのです。 Sh1 NO.1～12がSheet2 Sh1 NO.13～24がSheet3 ... 10枚のシートにしたいのですが、このマクロにどのような命令を加えればよろしいでしょうか？ お手数ですがよろしくお願いいたします。
- 締切済み
- オフィス系ソフト
- ExcelにおけるVBAで、データの振り分けをしたい
Sub a() Dim i As Long Dim s As Long Dim b As Worksheet Dim c As Worksheet Dim maxi As Long Dim maxs As Long Application.ScreenUpdating = False With ThisWorkbook Set b = .Worksheets("bbb") Set c = .Worksheets("ccc") End With maxi = b.Range("A1").CurrentRegion.Rows.Count maxs = c.Range("A1").CurrentRegion.Rows.Count For i = maxi To 2 Step -1 For s = maxs To 2 Step -1 If c.Cells(s, 1) = b.Cells(i, 1) And c.Cells(s, 2) = b.Cells(i, 2) Then c.Cells(s, 14) = b.Cells(i, 3) End If Next s Next i Application.ScreenUpdating = True End Sub ワークシートcとワークシートbの1列目と2列目が一致したときにだけ、cの14列目にbの3列目のデータを代入したく思い、以上のようなコードを書きましたが、重くて終わる様子がありません。 ・そもそもあっているのか、あっていないならどこを修正すればよいか ・早く終わるようにするにはどうしたらいいか アドバイスをよろしくお願いします。
- 締切済み
- Visual Basic
- エクセルで表を展開するマクロを作りたい
こんにちは。 エクセルで表を展開したいのですがマクロが作れません。 どなたか詳しい方教えて下さい。 A B C D １ 1,2,3 abc def ghi を A B C D １ 1 abc def ghi ２ 2 abc def ghi ３ 3 abc def ghi というように展開したいです。 10列目くらいまで対応したマクロが作りたいです。 Sub test() 'この行から Dim i, j, k As Long Dim myArray As Variant For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 If Not Cells(i, 1) Like "*" & "," & "*" Then i = i - 1 myArray = Split(Cells(i, 1), ",") k = UBound(myArray) Rows(i + 1 & ":" & i + k).Insert For j = 0 To k Cells(i + j, 1) = myArray(j) Next j Next i For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row If Cells(i, 2) = "" Then Cells(i, 2) = Cells(i - 1, 2) End If Next i Columns("A:B").AutoFit End Sub 'この行まで これにどう付け足せばいいでしょうか？ どうかご教授お願い致します。
- ベストアンサー
- Windows XP
- VBA エクセル 列の並び替え
左から右にA、B、Cと値が入っています。 ABC以外の文字が列に入っていたら、削除するというマクロを組みましたが、範囲を設定するところでエラーが出てしまいました。 なぜでしょうか？ 教えて下さい。 Sub arrange() Dim rg As Range Dim i As Long i = 1 Do rg = Cells(i, 1) If rg <> "A" And rg <> "B" And rg <> "C" Then Range(i & ":" & i).Delete End If i = i + 1 Loop Until (i & "1") = "" End Sub
- ベストアンサー
- オフィス系ソフト
- VBA クラスモジュールの使い方わかりません。
為替データで検証中なのですがネットで使いたいクラスモジュールがあり、値の渡し方などわからなくて困ってます。 過去1ヶ月のデータで日付、始値、高値、安値、終値並んでいる値を標準モジュールからTRと言う名のクラスモジュールに渡して計算したいのですがわかりません。 標準モジュールのみで簡単なマクロを作れるレベルです。 下がTRクラスモジュールです。 どなたかお助けください。 Option Explicit Public Version As Long Public Description As String Public NumInSequences As Long Public NumParams As Long Private Sub Class_Initialize() Version = &H10000 Description = "TR(真のレンジ)" NumParams = 0 NumInSequences = 4 End Sub Public Sub Calc(A() As Double, O() As Double, H() As Double, L() As Double, C() As Double) Dim I As Integer Dim LastClose As Double '前日の終値 For I = LBound(A) To UBound(A) If C(I) = Invalid Then A(I) = Invalid GoTo NextElem End If Dim D1 As Double '今日の高値と安値の差 Dim D2 As Double '前日の終値から今日の高値までの差 Dim D3 As Double '前日の終値から今日の安値までの差 If LastClose = Invalid Then A(I) = Invalid LastClose = C(I) GoTo NextElem End If ' 3つのパターンのレンジを計算 D1 = H(I) - L(I) D2 = H(I) - LastClose D3 = LastClose - L(I) If D1 > D2 Then A(I) = D1 Else A(I) = D2 End If If (A(I) < D3) Then A(I) = D3 End If LastClose = C(I) NextElem: Next End Sub
- ベストアンサー
- オフィス系ソフト
- 文字列からアルファベットを抽出（２）
以下、文字列から英字を抜き出すサンプルを頂戴しました。 Sub test() Dim i, k As Long Dim str, buf As String For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row Cells(i, 3) = WorksheetFunction.Substitute _ (WorksheetFunction.Substitute(Cells(i, 1), "]", ""), "[", "") For k = 1 To Len(Cells(i, 3)) str = Mid(Cells(i, 3), k, 1) If str Like "[A-z,Ａ-ｚ]" Then buf = buf & str End If If Len(buf) > 0 And Not str Like "[A-z,Ａ-ｚ, ]" Then Exit For Next k Cells(i, 2) = buf buf = "" Next i Columns(3).ClearContents End Sub 上記に以下の2つの機能を付け足したいです。 2文字以下の英字の時は英字がなかったものとして空白をかえしてほしい。→（1） （例）身長が3cm伸びた田中君→空白 （例）身長が3cm伸びたXYZ君→XYZ （例）こちらABC放送局→ABC 最初の一塊と後から出てくる一塊の長いほうをかえしてほしい。→（2） （例）学期末TESTの成績はAAAです→TEST（前が長い） （例）学期末TESTの成績はABCDです→TEST（同じ長さ） （例）学期末TESTの成績はABCDEです→ABCDE（後が長い） (1)と(2)を状況に応じて機能させたり停止したりしたいので その部分のソースを明示して頂けましたら幸いです。 厚かましいお願いですが、何卒よろしくお願いいたします。
- ベストアンサー
- その他MS Office製品
- ２つのリストボックスを使っての抽出
２つのリストボックスでの複数選択でのフィルタをかけたいと思い、色々試行錯誤でイカのようにやってみましたが、何も抽出されない状態になります。下は最初にやってみてエラーになりました。 顧客タイプがアルファベットで文字列なのですが、ダブルクォーテーションの付き方が問題だと思うのですが、なかなか思うようになりません。アドバイスお願いします。 また、見よう見まねで初めて書いたようなコードなので無駄も多いと思いますが、そこのあたりのアドバイスも頂けるとうれしいです。宜しくお願いします。 Dim ctl1 As Control Dim ctl2 As Control Dim abc As String Dim aaa As Long Dim bbb As Variant Dim ddd As Variant Dim quot As String Set ctl1 = Me!検索1 Set ctl2 = Me!検索2 abc = "[月] in (" aaa = Len(abc) If ctl1.ItemsSelected.Count = 0 Or ctl2.ItemsSelected.Count = 0 Then MsgBox "月か顧客タイプの選択がされていません！", , "エラー" Exit Sub End If For Each bbb In ctl1.ItemsSelected If Len(abc) > aaa Then abc = abc & "," End If abc = abc & ctl1.Column(0, bbb) Next bbb quot = Chr(34) abc = abc & ") and [顧客タイプ] in (" & quot For Each ddd In ctl2.ItemsSelected If Len(abc) > aaa Then abc = abc & "," End If abc = abc & ctl2.Column(0, ddd) Next ddd abc = abc & quot & ")" Me.Filter = abc Me.FilterOn = True 最初は以下のようにしてもやってみました。 Dim ctl1 As Control Dim ctl2 As Control Dim abc As String Dim def As String Dim aaa As Long Dim bbb As Variant Dim ccc As Long Dim ddd As Variant Dim quot As String Dim ad As String Set ctl1 = Me!検索1 Set ctl2 = Me!検索2 abc = "[月] in (" aaa = Len(abc) If ctl1.ItemsSelected.Count = 0 Or ctl2.ItemsSelected.Count = 0 Then MsgBox "月か顧客タイプの選択がされていません！", , "エラー" Exit Sub End If For Each bbb In ctl1.ItemsSelected If Len(abc) > aaa Then abc = abc & "," End If abc = abc & ctl1.Column(0, bbb) Next bbb abc = abc & ")" quot = Chr(34) def = "[顧客タイプ] in (" & quot ccc = Len(def) For Each ddd In ctl2.ItemsSelected If Len(def) > ccc Then def = def & "," End If def = def & ctl2.Column(0, ddd) Next ddd def = def & quot & ")" ad = abc And def Me.Filter = ad Me.FilterOn = True こちらは型が違う、とエラーになります。
- ベストアンサー
- オフィス系ソフト
- EXCEL VBA 文字列検索とコピー
以前にも同じ質問をさせて頂いたのですが、どうも上手くいかないので今一度お願い致します！ 名簿を作成していて、現在下記のようなシートになっています。 [ Sheet1 ] Ａ Ｂ Ｃ Ｄ Ｅ Ｆ Ｇ Ｈ 日付 ○ ○ ○ ○ 名前 電話 メール このＦ列の名前を検索して、検索文字に該当する全てのセルの行ごと（出きればA1:H2の範囲）コピーして、Sheet2に貼り付けたいです。 現在のコードは、以下のようになってます。 宜しくお願いします！！ Sub 検索1() Dim myFind As Variant Dim myfRow As Long, c As Range Dim CopySh As Worksheet Dim i As Long Dim num As Integer Set CopySh = Worksheets("Sheet2") 'コピー先のセルの最初の行 i = 1 '================================== myFind = Application.InputBox("検索文字をカナで入力してください", Type:=2) If VarType(myFind) = vbBoolean Or myFind = "" Then Exit Sub With Worksheets("Sheet1").Cells(4.4) Set c = .Find(myFind, , xlValues, xlWhole) If Not c Is Nothing Then myfRow = c.Row Do c.Copy CopySh.Cells(i, 1) 'コピー Set c = .FindNext(c) i = i + 1 Loop Until c Is Nothing Or myfRow = c.Row End If End With Beep '終了の合図
- ベストアンサー
- オフィス系ソフト
- エクセルVBA どうしても動きません。
お世話になります。 なかなか上達しない超初心者です。 ↓↓ですが、Activesheetにすると動くのに、シート名を元々存在するシート”実験"に指定すると動きません（データ内容はまったく同じで、A列に色んな名前が入っていて、重複しているとC列に重複と入力します）。 2日間試行錯誤したのですが、やっぱり動かず・・・ ちなみに、Activateにするとアクティブになるし、CurrentRegionも選択できるのに なんでうごかないんでしょうか・・・ 何卒ご指導くださいませ。よろしくお願いいたします！！！！！！ Sub Test2() With Sheets("実験").Range("A1").CurrentRegion Dim i As Long Dim LastRow As Long LastRow = Range("A" & Rows.Count).End(xlUp).Row For i = 1 To LastRow If WorksheetFunction.CountIf(Range("A:A"), Cells(i, 1)) > 1 Then Cells(i, 3) = "重複" End If Next i End With End Sub Sheets("実験")をActivesheetに変えると別のシートがしっかり動いてくれます・・・が、なんとしてでも”実験”シートに動いていただきたいです・・・。
- ベストアンサー
- Visual Basic
- コードの簡略化 VBA
dim a as string dim b as string dim c as string dim d as string dim e as string dim f as string dim g as string dim h as string dim i as string a = "○○" b = "○○" c = "○○" d = "○○" e = "○○" f = "○○" g = "○○" h = "○○" i = "○○" 上記のような形でたくさん宣言しているのですが、 実際はもっとあり、これだととても長いコードになってしまいます(・・;) なんとか簡略化したいとは考えたのですがよい方法が見つからず 皆さんよろしくお願いいたします_(_^_)_
- ベストアンサー
- Visual Basic
お礼
早速ご回答頂き、ありがとうございます！ 希望通りになりました！