• ベストアンサー

EXCELのマクロ :再帰的式を使って書き換える

次のEXCELのマクロ プログラムを再帰的式を使って シンプルにするにはどんな風にすればよういのでしょうか。よろしくお願いします。 Public Sub p() Dim c, base As Range Dim str As String Dim i1, i2, i3 Dim c1, c2, c3 Dim o1, o2, o3 Set base = Range("A1") c = 0 str = "ABCD" For i1 = 1 To Len(str) c1 = Mid(str, i1, 1) o1 = Replace(str, c1, "")    For i2 = 1 To Len(o1)    c2 = Mid(o1, i2, 1)    o2 = Replace(o1, c2, "")      For i3 = 1 To Len(o2)      c3 = Mid(o2, i3, 1)      o3 = Replace(o2, c3, "")      base.Offset(c).Value = c1 & c2 & c3 &       c4 & c5 & o5      c = c + 1      Next    Next Next End Sub

  • taktta
  • お礼率72% (1031/1430)

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

  • ベストアンサー
  • BLUEPIXY
  • ベストアンサー率50% (3003/5914)
回答No.2

こんな感じですかね If strLen = 0 Then を If strLen = 1 Then Range("A1").Offset(c).Value = result & selectList に変えれば、呼び出しを一段減らせます 何回も実行する場合には、 static cをやめて 関数の外部の一番上で dim c p2でc=0して下さい。 baseも使いたければ、同様 rp("","ABCDEF")にもできますよん。 '--------------------------------------------- Public Sub p2() Call rp("", "ABCD") End Sub Public Sub rp(ByVal result As String, ByVal selectList As String) Static c As Integer Dim i, strLen As Integer, choice As String strLen = Len(selectList) If strLen = 0 Then Range("A1").Offset(c).Value = result c = c + 1 Else For i = 1 To strLen choice = Mid(selectList, i, 1) Call rp(result & choice, Replace(selectList, choice, "")) Next End If End Sub

taktta
質問者

お礼

おかげで解決お世話になりました。 再帰法のこつがいくぶん理解できました。今度は自力で考えます。

taktta
質問者

補足

回答に影響はないのですが。 for i3の中の式は base.Offset(c).Value = c1 & c2 & c3 & o3の誤りでした。

その他の回答 (1)

  • hana-hana3
  • ベストアンサー率31% (4940/15541)
回答No.1

一応動かして見ましたが、前提条件が見えません。 単なる「ABCD」の並び替えなのでしょうか? 全ての組み合わせを求めるのでしょうか? 実行結果は3文字の並びになっていますし・・・。 「4文字から、3文字の組み合わせ」を得るのでしょうか?

taktta
質問者

お礼

失礼しました。提示のプログラムにいくぶんあやまりがありました。 文字列の順列を字引き式に表示のプログラムを再帰を使って修正するのが目的でした。

関連するQ&A

  • Excelのマクロについて

    文字列から数値だけを抽出するマクロを見つけたのですが、抽出するデータを選択してから実行しなければなりませんでした。 抽出するデータはAセル以下にしかないので、データを選択しないでも実行できるようにするにはどうしたら良いのでしょうか? 宜しくお願いします。 以下見つけたマクロです。  Sub test()  Dim mydata As String  Dim c As Range  Dim i As Integer  For Each c In Selection   mydata = ""  For i = 1 To Len(c)   If Mid(c, i, 1) >= 0 And Mid(c, i, 1) <= 9 Then   mydata = mydata & Mid(c, i, 1)    End If   Next   c.Offset(0, 1) = mydata   Next  End Sub

  • Excelのマクロで○○マス計算

    Excelで,下記のようなマクロ(その1)を作りました。(こちらで教えていただきました) できれば,これに加えて,任意のセルに1桁の数値を入れたら6×6や7×7のシートが作れるようにしたいのです。 自分なりに試してみましたが,コンパイルエラー「変数が定義されていません」の連発です。どこを書き換えればうまくいくでしょうか。 Option Explicit Sub macro1() Dim idxC, idxR, wkNum As Integer Dim wkList, wkChar As String Randomize Range("a1:z20").ClearContents wkList = "0123456789" For idxC = 3 To 12 wkNum = Int(Rnd() * Len(wkList)) + 1 wkChar = Mid(wkList, wkNum, 1) Cells(2, idxC) = Val(wkChar) wkList = Replace(wkList, wkChar, "") Next idxC wkList = "0123456789" For idxR = 3 To 12 wkNum = Int(Rnd() * Len(wkList)) + 1 wkChar = Mid(wkList, wkNum, 1) Cells(idxR, 2) = Val(wkChar) wkList = Replace(wkList, wkChar, "") Next idxR End Sub

  • エクセルのマクロ

    Sub test() x = Range("b1") z = Len(x)  For i = 1 To z   Range("a1").Offset(i - 1, 0).Value = Mid(x, i, 1)  Next i End Sub 上記は、"B1"に入力されているデータを、"A1"から下方向に一文字ずつ入力していくマクロです。 これに条件を付け加えたいのですが。 "今日(きょうは)雨[あめ]でした"のように、"( )"や"[ ]"内の文字はカッコも含めてフォントが赤(ColorIndex = 3)になるようにしたいのですが。 上の例だと、"(きょうは)"と"[あめ]"のフォントが赤になります。 おわかりの方がいましたら、お願いいたします。

  • エクセルのマクロについて(再び)

    http://oshiete1.goo.ne.jp/kotaeru.php3?q=1185170 で、質問させていただいたものです。 教えていただき、印刷できるようになったのですが、 Sub 楕円1_Click() Dim i '●●変数の宣言●● Worksheets("sheet1").Activate For i = 2 To 3 '300 Cells(1, "F") = i Range("a1:c8").PrintOut Next i End Sub というマクロを組んでいます。 >For i = 2 To 3  を >For i = 2 To 50  としてみましょう >こうすると、iが2~50まで変化します。 >で、50-1=49枚印刷されます。 と、教えていただいたのですが、 データが絶対に50件と決まっているわけではないので、データがあるところだけを印刷する場合、どのようにしたら良いのでしょうか。 教えてください。よろしくお願いいたします。

  • エクセルマクロで教えてください

    マクロ初心者です。アドバイスをお願いします。以下のマクロですとB列の100行目までの塗りつぶしのセルのカウントは出来るのですが、シート上の全てをカウントしたいのです。1TO 100の100の部分をどう変更したら良いのか教えてください。 Sub セルの色数1() Dim I As Integer Dim Count As Integer Count = 0 For I = 1 To 100 If Cells(I, 2).Interior.ColorIndex <> xlNone Then Count = Count + 1 Next I Range("C1").Value = Count End Sub

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

    初心者です。 下記モジュールで”あいうえお”を消しているのですが 凄く動きが遅いです。 もう少し高速に処理できる方法があれば教えてください。 (C2:C200)のセルには必ず各文の末尾に”あいうえお”が入力されている状態です。 Sub 文削除() '余計な分削除する Dim rg As Range For Each rg In Range("C2:C200") rg.Value = Replace(rg.Value, "あいうえお", "") Next End Sub

  • Excel VBAで半角

    Excel VBAで半角 A列が半角のときに、B列にoと表示させるために下記のソースを考えたのですがうまくいきません。初歩的な質問だとは思いますがよろしくお願いします。 Sub 半角判定() Dim i For i = 2 To Range("g65536").End(xlUp).Row If Application.Len(Cells(i, 1)) = Application.LenB(Cells(i, 1)) Then Cells(i, 2) ="o" End If Next End Sub

  • Excel エクセル マクロ VBA

    エクセルマクロで指定したシート(2シート目)から末尾のシートまで印刷したい場合、下記のようなコードで良いでしょうか? Sub Sample1() Dim i As Long For i = 2 To Sheets.Count ActiveWorkbook.Sheets(i).Select (Replace:= False) Next i Activesheet.PrintOut Preview:=True End Sub

  • EXCEL VBAでのコーディング方法

    A列      1.1       1.1.1      1.1.1.1     1.1.1.2     ・・・ 1.1.1.10 1.1.2 1.1.3 と縦に並んでいるデータがあります。B列には年月日が入っています。 1.1は1.1.1~1.1.3の中の最小年月日 1.1.1は1.1.1.1~1.1.1.10の中の最小年月日 としてC列に表示させたいと思っています。 Sub StrCount() shname = ActiveSheet.Name For i = 4 To Sheets(shname).Range("J2").Value lstrBuf = Sheets(shname).Range("A" & i).Value llngCnt = Len(lstrBuf) - Len(Replace(lstrBuf, ".", "")) Next End Sub で.の数を取得する所までは考えたのですが、分岐の条件が 思いつきません。お教えいただけないでしょうか。

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

専門家に質問してみよう