- 締切済み
ＥＸＣＥＬマクロ
okormazdの回答
- okormazd
- ベストアンサー率50% (1224/2412)
nPr=n!/(n-r)! を使う。 factは再帰で階乗を求める関数、fact2はforループで階乗を求める関数。どちらでも好きなほうをどうぞ。 Sub npr() Dim n As Double, r As Double, npr As Double n = 10 r = 3 ' npr = fact(n) / fact(n - r) npr = fact2(n) / fact2(n - r) MsgBox npr End Sub Function fact(x As Double) As Double If x = 0 Then fact = 1 Else fact = x * fact(x - 1) End If End Function Function fact2(x As Double) As Double Dim v As Double, i As Double v = 1 For i = 1 To x v = v * i Next fact2 = v End Function
関連するQ&A
- このマクロの繰り返し？
もう、なにがなんやらで・・・ このマクロの繰り返しを入れ子で出来ないでしょうか? 加算しながら増やしていくので、わけわからなくなりそうです。 Option Explicit Sub hiat() Cells.Clear Dim s As Long, a As Long, b As Long, c As Long, d As Long, e As Long For a = 1 To 31 s = Rnd * 4 Cells(a, 1) = s If s >= 4 Then Exit For '4がでたら終わり。 Next For b = 2 To 31 s = Rnd * 4 Cells(a, b) = s If s >= 4 Then Exit For '4がでたら終わり。 Next Cells(a + 1, b).Select 'セルの移動 Cells(a + 1, b).Activate For c = 1 To 31 - a s = Rnd * 4 ActiveCell(c) = s If s >= 4 Then Exit For '4がでたら終わり。 Next Cells(a + c, b + 1).Select 'セルの移動 Cells(a + c, b + 1).Activate For d = 1 To 31 - a - c s = Rnd * 4 ActiveCell(d) = s If s >= 4 Then Exit For '4がでたら終わり。 Next Cells(a + c + d - 1, b + 2).Select 'セルの移動 Cells(a + c + d - 1, b + 2).Activate For e = 1 To 31 - a - b - c - d s = Rnd * 4 ActiveCell(e) = s If s >= 4 Then Exit For '4がでたら終わり。 Next Cells(a + c + e - 1, b - 1 + d + 1).Select 'セルの移動 Cells(a + c + e - 1, b - 1 + d + 1).Activate End Sub
- 締切済み
- Visual Basic
- エクセルで
お世話になります Sub 請求書印刷() p = 0 For r = 2 To 134 Step 22 For c = 1 To 236 Step 5 If Cells(r, c) = "" Then GoTo pr p = p + 1 Next c Next r pr: Sheets("請求書").PrintOut From:=1, To:=236, Copies:=1, Collate:=True, Preview:=False End Sub 上記のマクロで、Ａの2-3（セルの結合）が空白だったらに 変えるのにはどしたらいいでしょうか よろしくお願いいたします
- ベストアンサー
- Visual Basic
- エクセルのマクロについて
お手数ですが誰か教えてください！ BのデーターをAに集計するマクロを作ったのですが 処理速度とっても遅いのです。 高速で処理する方法はありませんでしょうか？ 私が作ったマクロ Sub 集計() Dim Z As Integer Dim i As Integer Dim X As Integer For Z = 2 To 2000 For i = 2 To 2000 For X = 3 To 20 If Worksheets("A").cells(Z, 1) = Worksheets("B").cells(i, 1) And Worksheets("A").cells(1, X) = Worksheets("B").cells(i, 14) Then Worksheets("A").cells(Z, X) = Worksheets("B").cells(i, 16) End If Next X Next i Next Z End Sub どこかが間違っている気がしますがマクロ初心者のため 先に進めません。 どうかご教授よろしくお願い致します。
- 締切済み
- Visual Basic
- エクセルマクロの部分比較について
こんばんわ！ エクセルマクロのLike演算子を使用した部分比較をしようとしたのですが下記のtes1は動いたのですが、tes2が動きません。 動くマクロ Sub tes1() For i = 5 To 20 Step 1 If Cells(i, 1) Like "*" & Range("b1") & "*" Then Cells(i, 3) = 1 End If Next i End Sub 動かないマクロ Sub tes2() Dim name As String name = Range("b1") For i = 5 To 20 Step 1 If name Like "*" & Cells(i, 1) & "*" Then Cells(i, 3) = 1 End If Next i End Sub まだ、理解が足りていないところが多く、動かない理由が分からないですが、よろしければ、説明を兼ねてアドバイスのほどよろしくお願いいたします。
- ベストアンサー
- オフィス系ソフト
- マクロで最終行を空欄にしたいのですが、出来なくて困ってます
VBA初心者です。 仕事で、見積書を作成する際に多い時には２～3枚にわたる時で、マクロが既に組んであるのですが、最終行は空欄のはずが、2ページ目のデータが上がってきています。 どうすれば、最終行を空欄に出来るのでしょうか？ このマクロが、延々と続いています。 Dim a As Integer Dim c As Integer Dim count As Integer b = 1 c = 1 count = 1 '明細1の処理 a = 1 If Sheet2.Cells(a + 3, 2) = "" Then GoTo 20 Sheet13.Cells(b + 22, 1) = count Sheet13.Cells(b + 22, 2) = Sheet2.Cells(a + 3, 3) Sheet13.Cells(b + 22, 12) = Sheet1.Cells(c + 14, 5) Sheet13.Cells(b + 22, 13) = Sheet1.Cells(c + 14, 6) Sheet13.Cells(b + 22, 17) = Sheet1.Cells(c + 14, 10) If b = 26 Then JUMP1 If b = 74 Then JUMP1 b = b + 1 c = c + 1 count = count + 1 For a = 2 To 8 If Sheet2.Cells(a + 3, 2) = "" Then GoTo 10 Sheet13.Cells(b + 22, 2) = Sheet2.Cells(a + 3, 3) If b = 26 Then JUMP1 If b = 74 Then JUMP1 b = b + 1 Next a 10 If b = 26 Then JUMP1 If b = 74 Then JUMP1 b = b + 1 初心者の為、宜しくお願い致します。
- 締切済み
- オフィス系ソフト
- エクセルのマクロについて
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
- 締切済み
- オフィス系ソフト
- ExcelのVBAがオーバーフローに！？
読んで頂きありがとうございます。 以前に質問しました時に回答を頂き凄く助かっていたのですが、何故か「オーバーフロー」と表示されてしまいます。 ひょっとしたら桁なのかも知れません。 下記のVBAを教えて頂きしようしていました。 Option Explicit Sub Test() Dim c(), p(), q(), i, j, l, r, k As Long r = Range("B2").End(xlDown).Row l = Range("D2").End(xlDown).Row ReDim c(r - 2), p(r - 2), q(r - 2) For i = 1 To r - 2 c(i) = Cells(i + 2, 2).Value p(i) = Cells(i + 2, 3).Value q(i) = i + 2 Next i For i = 1 To r - 3 For j = i + 1 To r - 2 If c(i) > c(j) Then k = c(i) c(i) = c(j) c(j) = k k = p(i) p(i) = p(j) p(j) = k k = q(i) q(i) = q(j) q(j) = k End If Next j Next i For i = 1 To r - 2 Cells(i + 2, 7).Value = c(i) For j = 3 To r If Cells(j, 4).Value = c(i) Then Cells(i + 2, 8).Value = p(i) - Cells(j, 5).Value If p(i) - Cells(j, 5).Value <> 0 Then Range("B" & q(i)).Interior.ColorIndex = 6 Range("D" & j).Interior.ColorIndex = 6 End If Exit For End If Next j Next i For i = 3 To r k = 0 For j = 3 To l If Cells(i, 2).Value = Cells(j, 4).Value Then k = 1 Exit For End If Next j If k = 0 Then Range("B" & i).Interior.ColorIndex = 35 End If Next i For i = 3 To l k = 0 For j = 3 To r If Cells(i, 4).Value = Cells(j, 2).Value Then k = 1 Exit For End If Next j If k = 0 Then Range("D" & i).Interior.ColorIndex = 35 End If Next i End Sub デパックのClickすると15行目辺りの「k = c(i)」が黄色くなります。 正直言ってマクロとか全く解りませんが、コピーして使っていました。 どこをどう変更すれば良いのか教えて頂ければ助かります。 よろしくお願いします。
- ベストアンサー
- Excel（エクセル）
- エクセルのマクロで打ち込んだ数字のより分けをしたいと思い下記のコードで
エクセルのマクロで打ち込んだ数字のより分けをしたいと思い下記のコードで実行してみたのですが、空白セルを選択したところで砂時計のままになりフリーズしてしまいます。どこが間違っているのでしょうか？ ちなみに手動で空白選択部分を右クリック→削除（上方）としてもやはり固まってしまいます。やりたいのはA列にランダムに打ち込んだ数字の５千番台、９千番台をB列、C列に移して空白セルを埋めると言うものです。手動でもだめと言うことは何か別の理由も考えられますでしょうか？使用PCはWIN－XPです。 Sub Sorting1() Dim R As Long For R = 1 To Cells(Rows.Count, "A").End(xlUp).Row If Cells(R, "A").Value >= 5000 And Cells(R, "A").Value <= 5999 Then Cells(R, "B").Value = Cells(R, "A").Value Cells(R, "A").Value = "" End If If Cells(R, "A").Value >= 9000 And Cells(R, "A").Value <= 9999 Then Cells(R, "C").Value = Cells(R, "A").Value Cells(R, "A").Value = "" End If Next R On Error Resume Next Range("A1:C10000").Select Selection.SpecialCells(xlCellTypeBlanks).Select Selection.Delete Shift:=xlUp Range("A1").Select End Sub
- ベストアンサー
- Visual Basic
- このVBAソースのどこが間違ってるか教えてください
Dim csp As Integer 'ストップ Dim css As Integer 'ストップorスタート Sub Quest2() If css = 0 Then css = 1 Quest2a Else cstp = 1 css = 0 End If End Sub Sub Quest2a() Sheets("Sheet1").Select Range("B1:J10").Select Selection.Interior.ColorIndex = x1None Range("a1").Select cstp = 0 Do r = 1: c = 5 For i = 0 To 15 If i < 9 Then Cells(r, c).Interior.ColorIndex = x1None r = r + 1 If i < 5 Then c = c + 1 Else c = c - 1 End If Cells(r, c).Interior.ColorIndex = 3 Else Cells(r, c).Interior.ColorIndex = x1None r = r - 1 If i < 13 Then c = c - 1 Else c = c + 1 End If Cells().Interior.ColorIndex = 3 End If 'タイミング For tm1 = 1 To 1000: For tm2 = 1 To 100: Next If cstp = 1 Then Exit For End If Next DoEvents If cstp = 1 Then Exit For End If If r = 3 And c = 5 Then Cells(r, c).Interior.ColorIndex = x1None End If Next DoEvents If cstp = 1 Then Exit Do End If Loop Cells(10, 9) = Cells(r, c) Cells(10, 9).Interior.ColorIndex = 8 End Sub
- ベストアンサー
- その他（プログラミング・開発）
- エクセルマクロでEnd Subが見つからないとでる
Excelのマクロ記述についての質問です． 以下のマクロはエクセルにない関数「IMMULT」をあらかじめ定義するためのものです．（技術計算のHPより入手し，コピーして貼り付けたものです） これを実行すると「End Subがみつからない」と出てしまいます．End Subは記述しているのになぜでしょうか，どなたか解決策を教えて頂けませんか！ Sub 関数定義() Public Function IMMULT(a As Range, b As Range) As Variant Dim r1 As Integer, r2 As Integer, c1 As Integer, c2 As Integer, nn As Integer Dim r As Integer, c As Integer Dim cr As Integer, cc As Integer Dim n As Integer Dim mm() As Variant r1 = a.Rows.Count r2 = b.Rows.Count c1 = a.Columns.Count c2 = b.Columns.Count If (c1 = r2) Then nn = c1 Else Exit Function End If cr = r1 cc = c2 ReDim mm(1 To cr, 1 To cc) For r = 1 To cr For c = 1 To cc mm(r, c) = 0 For n = 1 To nn mm(r, c) = IMSUMa(mm(r, c), IMPRODUCTa(a.Cells(r, n), b.Cells(n, c))) Next Next Next IMMULT = mm End Sub
- ベストアンサー
- Excel（エクセル）
お礼
回答ありがとうございます。 すいません、質問が悪かったようで、 欲しいのは１、２、３～９、８、７の７２０組の数字です。