• 締切済み

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に表示したいです。

みんなの回答

  • noah7150
  • ベストアンサー率46% (116/251)
回答No.3

> 質問ですが、個人用のマクロブックとはなんでしょうか? マクロを記録するときマクロ名の下にマクロの保存先の選択が出来ます そのとき個人用のマクロブックとすると、記録するマクロは作業中のブックではなく PERSONAL.XLS と言う名前で作成されます。 このブックはExcelを実行すると自動的に読み込まれブックが違っても記録したマクロが実行できるようになります。 ただ、PERSONAL.XLS と言う名前で保存されるだけで実際は XLSTART に保存されているブックはExcel起動時に自動で呼び出されます。 なので、自分で作成したマクロブックをこの中に入れておくだけでマクロが使用できるようになるわけです。 しかし非表示にしていないと自動で呼び出されたブックも見えるようになります。 PERSONAL.XLSも非表示にしていますが、ウィンドウで再表示を選択すれば個人用のマクロブックも見えるようになります

  • noah7150
  • ベストアンサー率46% (116/251)
回答No.2

作成したマクロブックを個人用マクロブック(PERSONAL.XLS)が保存される C:\Documents and Settings\[ユーザー名]\Application Data\Microsoft\Excel\XLSTART\ に複写しておくとExcel起動時に自動的に呼出されます。 非表示にして保存しておくと個人用マクロブックと同様に開かれてても見えなくなります。 ユーザーツールバーを新規作成してマクロブックに添付しておくとマクロ起動も便利です。(添付は新規作成ボタンがある画面の一番したの添付ボタンで出来ます) 構文は自分でも少しやってみてください。 全構文載せて、したいなんて丸投げに等しいですよぉ~。 ガンバレ!

510motoki
質問者

お礼

ありがとうございます。 質問ですが、個人用のマクロブックとはなんでしょうか?

  • ts3m-ickw
  • ベストアンサー率43% (1248/2897)
回答No.1

ExcelのマクロはExcelファイルの中か、個人用マクロブックの中にしか保存できません。 どのPCでも、どのファイルでも実行できるというのはちょっと無理ですね。 マクロを全てのファイルに組み込むか、個人用マクロブックを全てのPCにコピーするとかで対処するしかないと思います。 置換した文字数表示については面倒なのでパス。 Replace関数には置換した文字数を返す機能は無かったと思うので、やろうとすると修正が大変かな、と。

関連するQ&A

  • 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

  • EXCEL VBA 文字列 

    下記のソースの場合、一つのセル(例えばA1)に【鈴木 太郎】とあれば、隣のセル(B1)に"鈴木 太郎"と表示されます。 (これを一つのセルに【鈴木 太郎】【佐藤 太郎】【伊藤 太郎】とあった場合は、"鈴木 太郎】【佐藤 太郎】【伊藤 太郎"と表示されます。) 例えば、C1には【鈴木 太郎】【佐藤 太郎】【伊藤 太郎】とあった場合には、C2には"鈴木 太郎"、D2に"佐藤 太郎"、E2に"伊藤 太郎"とすることは可能でしょうか? ※行によって異なり、【○○ ○○】はいくつあるとは限らないとします。 よろしくお願いいたします。 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

  • 作成方法についての質問です。

    下記のマクロで実行すると添付画像[現状]のようになってしまいます。 私としては[こうなってほしい]の形にしたいのですが、どこに何を組み込めばよいかわかりません。 誰か教えてください。 Dim Matches As Object Dim Match As Object Dim i As Long, j As Long Dim a As Variant With CreateObject("VBScript.RegExp") Set rng = Range("A1", Cells(Rows.Count, 1).End(xlUp)) Application.ScreenUpdating = False For i = 1 To rng.Rows.Count If InStr(1, rng.Cells(i, 1).Value, "(", 1) > 0 Then .Pattern = "\(([A-z\d,]+)" Else .Pattern = "([A-z\d,]+)" End If .Global = True Set Matches = .Execute(StrConv(rng.Cells(i, 1).Value, vbNarrow)) If Matches.Count > 0 Then a = Matches(0).SubMatches(0) a = Split(a, ",") Cells(i, 2).Resize(, UBound(a) + 1).Value = a End If j = 0 Next End With Application.ScreenUpdating = True Set rng = Nothing End Sub

  • マクロ エクセル2003

    いつも回答して頂き感謝しています。 原紙のブックを開き、別の名前を付けて保存するマクロを考えています。 原紙のブックを開くマクロはネットから探して、少し修正して出来あがったのですが、 この開いた原紙のブックに別の名前を付けて保存するマクロで困っています。 ただ単に名前を付けるだけだったら問題無いのですが、 その名前が既に保存されていないか確認した後、保存としたいのです。 ブックを開く記述を少し引用して出来ないかやってみたのですが、 Const Target2 As String = "C:\Users\Owner\Documents\" & NewFile で、定数式が必要です。と表示されエラーが発生してしまいます。 どのように変更したら上手くいくのでしょうか?宜しくお願い致します。 Sub Sample() Dim buf1 As String Dim buf2 As String Dim NewFile As String Dim ws1 As Worksheet Dim wb As Workbook Set ws1 = ThisWorkbook.Worksheets("作成") NewFile = "借入貸出" & ws1.Range("C4").Value & "." & ws1.Range("D4").Value Const Target1 As String = "C:\Users\Owner\Documents\借入貸出原紙.xlsx" Const Target2 As String = "C:\Users\Owner\Documents\" & NewFile & ".xlsx" buf1 = Dir(Target1) If buf1 = "" Then MsgBox Target1 & vbCrLf & "は存在しません", vbExclamation Exit Sub End If For Each wb In Workbooks If wb.Name = buf1 Then Application.DisplayAlerts = False Workbooks("借入貸出原紙.xlsx").Close Application.DisplayAlerts = True End If Next wb Workbooks.Open Target1 buf2 = Dir(Target2) If buf2 = "" Then End If End Sub

  • エクセルのマクロについて教えてください

    お世話になっております。 エクセルのマクロについて教えていただきたいのですが、 サンプルのファイルをこちらにアップしたのでよろしければご覧になってください。 http://kie.nu/yPV 質問したいことは、列Iに、各行の黄色いセルの数を表示させるマクロを作りたいのですが 途中まで何とかわかったのですがどうもうまくいきません。。 行11から各行にひとつずつ、黄色いセルが含まれていますが、その黄色いセルの中の数字を列Iに表示させたいです。行にデータがある限り、下までずっとです。 以下、途中までわかったマクロです。 Sub 黄セル値Copy() Const TgLeftUp = "A3" '<--対象範囲左上セル指定 Dim Rng As Range Dim Target As Range Set Target = Range(TgLeftUp, Cells(Rows.Count, _ Range(TgLeftUp).Column)) For Each Rng In Target.Resize(, 2) If Rng.Interior.ColorIndex = 6 Then If Rng.Column = Target.Column Then Rng.Offset(, 3).Value = Rng.Value Else Rng.Offset(, 2).Value = Rng.Value End If End If Next MsgBox "値 貼り付け完了。", vbInformation Set Target = Nothing End Sub でもこれを貼り付けてもうまくいきません。 正しいマクロを教えていただけないでしょうか?? 宜しくお願いいたします。 ※いつも、私の質問に対してまるで回答になってないような、ふざけた言葉を書き込んでは消してる方が一名だけいらっしゃいます。確か、鳥の写真をマイページに載せてる方です。 都度違反報告はしていますが、質問の趣旨に反する回答をされてる方一名、絶対にやめてください。

  • エクセルのマクロについて

    Sub ア_Click() Dim i As Long With ActiveSheet For i = 5 To .Cells(Rows.count, "C").End(xlUp).Row If InStr(.Cells(i, "C"), "ア") = 0 Then If InStr(.Cells(i, "D"), "ア(半角)") = 0 and .Cells(i,"D")<>"" Then MsgBox i & "行目" Cells(i, 2).Offset(0, -1).Value = "★" End If End If Next i End With End Sub このエクセルマクロはC列に「ア」があって、D列に「ア(半角)」の文字がない場合はメッセージというマクロなのですが、このマクロをア~ンまで同じ作業をしたいのですが、ひとまとめにマクロを組む事はできるのでしょうか?できる場合どのようにすれば良いでしょうか? 下記のようにして見たのですができませんでした。 Sub ア_Click() Dim i As Long With ActiveSheet For i = 5 To .Cells(Rows.count, "C").End(xlUp).Row If InStr(.Cells(i, "C"), "[ア-ン]") = 0 Then If InStr(.Cells(i, "D"), "[ア-ン](半角)") = 0 and .Cells(i,"D")<>"" Then MsgBox i & "行目" Cells(i, 2).Offset(0, -1).Value = "★" End If End If Next i End With End Sub

  • エクセル 2010 マクロ 検索

    http://okwave.jp/qa/q8562170.html 上記質問に追加です。 ※1 'D,E,F,G,H,I,K を検索してD,E,F,G,H,I に検索対象があった時 E,F,G,H,Iのいずれかだったら左横列の上に向かって (EならD 、FならE ・・・という具合に) 何か入力されているセルのM列の191000####をmsgboxで表示させたいです。 (画 F11セル(A-1)が検索ヒットした場合E9セル(R-01)を辿り、 その行のM列のセル(191000####)をmsgboxで表示 ※2 但し、検索結果がD列のデータだった時、その行のM列が191000####だった場合 M列の191000####をmsgboxで表示させたいです。 (画 D25セル(Y-1)対象の時) ※3 また、検索結果がD列のデータだった時、その行のM列が191000####以外だった場合 (空白だったり191000####以外の場合) M列の一番上の191000####をmsgboxで 191000####&「これは例外です」と表示させたいです。 (画 D24セル (X-1)対象の時) 現在のコードは下記のとおりです。 Sheet1に Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address <> "$A$3" Then Exit Sub Call 検索 Range("A1:A2").Clear Range("A1").Activate End Sub 標準モジュールに Sub 検索()  Dim Ws1 As Worksheet, Ws2 As Worksheet  Dim strKey As Variant  Dim s As String  Dim c As Range, bln As Boolean  Dim rng1 As Range  Dim cnt As Long    Set Ws1 = Sheet1  Set Ws2 = Sheet2    Ws1.Select    With Ws2   strKey = Application.Transpose(.Range("A1").Resize(2).Value)   strKey = Join(strKey, "")  End With    If Trim(strKey) = "" Then MsgBox "検索キーが空です", vbCritical: Exit Sub      With Ws1   Set rng1 = .Range("K2", .Cells(Rows.Count, "K").End(xlUp))   For Each c In rng1.Offset(, -10)     'D,E,F,G,H,I,Kを検索    s = c.Offset(0, 3).Value & c.Offset(0, 4).Value & c.Offset(0, 5).Value & c.Offset(0, 6).Value & c.Offset(0, 7).Value & c.Offset(0, 8).Value & c.Offset(0, 10).Value &        If StrComp(s, strKey, vbTextCompare) = 0 And c.Offset(0, 2).Value = "" Then     c.End(xlToRight).Activate c.Offset(0, 2).Value = Date          c.Resize(1, 14).Interior.ColorIndex = 6     bln = True     Exit For    End If   Next c      If Not bln Then    Ws2.Select    MsgBox "リストに存在しません", vbExclamation, "NotFound"   Else '加える    Call ReSearch(Ws1.Range("M2"), c.Row)    '再設定    Set rng1 = .Range("K6", .Cells(Rows.Count, "K").End(xlUp))    MsgBox "残り" & DoubleCountBlank(rng1.Offset(, -8), rng1) & "品目です。", vbInformation   End If  End With  Application.Goto Ws2.Range("A1"), True End Sub Sub ReSearch(Rng As Range, j As Long) '最初のセル, 終わりの行数 Dim i As Long Dim Ws As Worksheet With Rng.Parent For i = j To Rng.Row Step -1 If CStr(.Cells(i, Rng.Column).Value) Like "191000####" Then MsgBox "指図番号 " & vbCrLf & CStr(.Cells(i, Rng.Column).Value) & " の部品です" Exit For End If Next i End With End Sub Function DoubleCountBlank(rng1 As Range, rng2 As Range) '横並びのセルのブランクをカウントする (セル範囲1 , セル範囲2)  Dim i As Long  Dim cnt As Long  For i = 1 To rng1.Rows.Count   If VarType(rng2.Cells(i, 1)) = vbDouble Then    If rng1.Cells(i, 1).Value = "" And rng2.Cells(i, 1).Value <> 0 Then     cnt = cnt + 1    End If   End If  Next i  DoubleCountBlank = cnt End Function 宜しくお願い致します。

  • エクセルのマクロについて質問、次のマクロが欲しいです。「選択した範囲のセルに左から○○番目に半角スペースを挿入」

    エクセルのマクロについて質問、次のマクロが欲しいです (1)選択した範囲のセルに左から○○番目に半角スペースを挿入。 例:○○を1とした場合 1234 5678 9101 1235 5679 9102 1236 5680 9103 ↓ 1■234 5■678 9■101 1■235 5■679 9■102 1■236 5■680 9■103 *■はスペースのつもりです (2)選択した範囲のセルに右から○○番目に半角スペースを挿入。 例:○○を1とした場合 1234 5678 9101 1235 5679 9102 1236 5680 9103 ↓ 123■4 567■8 910■1 123■5 567■9 910■2 123■6 568■0 910■3 (3)選択セルの1番右の文字を上付き文字。 例: 1234 1235 1236 ↓ 1234←4を上付き 1235←5を上付き 1236←6を上付き 「選択した範囲のセル中にスペースやタブがあれば全部削除」 といった似たようなマクロを発見したのですが。これを利用してできないでしょうか? Sub 空白除去() Dim rng As Range Dim str as String For Each rng In Selection ' --- タブを除去 str = Replace(rng.Value, vbTab, "") ' --- 半角スペースを除去 str = Replace(str , " ", "") ' --- 全角スペースを除去 rng.Value = Replace(str , " ", "") Next End Sub お力添えよろしくお願いします。

  • エクセル マクロのいれ方

    エクセルを使って表を作っています。 自分のしたい事をするには、マクロを組まなくてはならないことが分かりました。 私はマクロは使ったことがないので、本来ならちゃんと勉強すべきなんですが、締め切りが迫ってるので、マクロのVBAを調べました。 したいのは、『ロックされているセル以外のデータをクリアにする』ということなんですが、その為には下記のVBA?を入れればいいらしいのです。 Sub UnlockCellClear() Dim Rng As Range For Each Rng In UsedRange   If Rng.Locked = False Then     Rng.Clear     Rng.Locked = False   End If Next End Sub ツール→マクロ→VBA→標準モジュール→Module1を開き、上記のVBAを入れてみましたが出来ませんでした。 そんな簡単なことじゃないんですかね? ど 質問の説明が下手でしたら申し訳ありません。

  • 2010 excel マクロ 記号の変化

    エラー発生で強制終了になってしまいます。2007年のexcelで作成したものですが、2010だと強制終了になってしまいます。 内容は□をダブルクリックすると■になるように作っています。 記述は2003年からのマクロ記述なので、変化が必要なのでしょうか? Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'セルをダブルクリックすると、・→○→△→×→・と変更する。 Dim S1 As String Dim S2 As String Dim S01 As String Dim S02 As String Dim S03 As String Dim S04 As String S1 = "□" S2 = "■" S01 = "・" S02 = "○" S03 = "△" S04 = "×" On Error GoTo ERR_12 sCheckXY S1, S2 sCheckX1234 S01, S02, S03, S04 sChangeXY S1, S2 Exit Sub ERR_12: End End Sub Sub sChangeXY(X As String, Y As String) '選択セルに□があれば■に変える Dim Str0 As String 'str1の左端 Dim Str1 As String 'strの右側更新 Dim Str2 As String 'strの左側更新 Dim Str20 As String 'strの左側一部保存 Dim L As Long Dim M As Long Dim N As Long Str1 = ActiveCell.Text L = Len(Str1) Debug.Print L If L = 0 Then End End If For N = 1 To L Debug.Print Str2 Str0 = Left(Str1, 1) If Str0 = X Or N = L Then If Str20 <> "" Then If N = L Then Str20 = Str20 + Str0 End If If MsgBox(Str20 & "  はチェックしますか?", vbYesNo, "選択肢") = vbYes Then Str2 = Str2 + Replace(Str20, X, Y) Str20 = Str0 Else Str2 = Str2 + Replace(Str20, Y, X) Str20 = Str0 End If Else Str20 = Str0 End If Else Str20 = Str20 + Str0 End If Str1 = Right(Str1, L - N) Next N ActiveCell.Value = Str2 End Sub Sub sCheckXY(X As String, Y As String) '選択セルがXならY,YならXにチェックをかえる If ActiveCell.Text = X Then ActiveCell.Value = Y End ElseIf ActiveCell.Text = Y Then ActiveCell.Value = X End End If End Sub Sub sCheckX1234(X1 As String, X2 As String, X3 As String, X4 As String) '選択セルがXならY,YならXにチェックをかえる If ActiveCell.Text = X1 Then ActiveCell.Value = X2 End ElseIf ActiveCell.Text = X2 Then ActiveCell.Value = X3 End ElseIf ActiveCell.Text = X3 Then ActiveCell.Value = X4 End ElseIf ActiveCell.Text = X4 Then ActiveCell.Value = X1 End End If End Sub

専門家に質問してみよう