ExcelVBAマクロの数値を2ケタに変更したい

このQ&Aのポイント
  • Excel VBAを使用して、数値を2桁の数字に変更したいです。具体的には、百ます計算のシートを活用して、2桁の数値で加算、減算、乗算を行いたいです。
  • VBAに詳しくないので、スクリプトを試しましたが、うまく動作しませんでした。自分で数値を変更しても結果が表示されません。
  • 他の人の作成物を使用するので、質問の適切さに不安があります。アドバイスがあれば、お願いします。
回答を見る
  • ベストアンサー

ExcelVBA マクロの数値を2ケタに変更したい

http://www.exvba.com/blog/?p=3974 こちらの百ます計算のシートをダウンロードし活用させて頂こうと思っていますが、2ケタのものが作れるかを試してみたいと思っています。例えば26+57とか、81-32とかです。掛け算だけは、2ケタ×1ケタにしたいです。 当方プログラムが初心者でスキル不足のため、VBAがよく分かりません。以下がスクリプトのようですが、色々数値を変えてみましたがダメでした。 <--ここから--> Option Explicit '100マス計算ジェネレータ by 達人養成塾 http://www.exvba.com/ Sub main() Dim calc As Long With Application calc = .Calculation .Calculation = xlCalculationManual InputBase Range("B5"), "+", False InputBase Range("B18"), "-", True InputBase Range("B31"), "×", False .Calculation = calc ' .Calculation = xlAutomatic End With End Sub Sub InputBase(bs As Range, op As String, bType As Boolean) With bs If Not IsEmpty(bs) Then .CurrentRegion.ClearContents End If If Not IsEmpty(.Offset(, 12)) Then .Offset(, 12).CurrentRegion.ClearContents End If SetLine bs, op, True, False SetLine bs, op, False, bType .CurrentRegion.Copy Destination:=.Offset(, 12) ExeCalc bs, op End With End Sub Private Sub SetLine(base As Range, ope As String, bRow As Boolean, add10 As Boolean) '起点セル、演算子、行か列か、値に10を足すか Dim c As Long, ar(9) As Long With base .Value = ope Application.Calculate With Worksheets("rnd") .Range("A2:B12").Sort key1:=.Range("B2"), order1:=xlAscending, Header:=xlYes For c = 3 To 12 ar(c - 3) = .Range("A" & c).Value Next End With If bRow Then For c = 1 To 10 .Offset(c).Value = ar(c - 1) Next ElseIf Not add10 Then For c = 1 To 10 .Offset(, c).Value = ar(c - 1) Next Else For c = 1 To 10 .Offset(, c).Value = ar(c - 1) + 10 Next End If End With End Sub Private Sub ExeCalc(base As Range, ope As String) Dim r As Long, c As Long With base.Offset(, 12) Select Case ope Case "+" For r = 1 To 10 For c = 1 To 10 .Offset(r, c).Value = .Offset(r).Value + .Offset(, c).Value Next Next Case "-" For r = 1 To 10 For c = 1 To 10 .Offset(r, c).Value = .Offset(, c).Value - .Offset(r).Value Next Next Case Else For r = 1 To 10 For c = 1 To 10 .Offset(r, c).Value = .Offset(r).Value * .Offset(, c).Value Next Next End Select End With End Sub <--ここまで--> こちら他者様の著作物になりますので、もしこうした質問が不適切でしたら削除させて頂きます。 もしよろしければアドバイスを頂けましたら幸いに思います。

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

  • ベストアンサー
  • watabe007
  • ベストアンサー率62% (476/760)
回答No.1

2ケタの足し算を作ってみました。参考に Sub Test()   Dim i As Long, myNum As Long, c As Range   With Range("B5")     .Resize(11, 23).ClearContents     .Value = "+"     .Offset(, 12).Value = "+"     Randomize     For i = 1 To 10       myNum = Int(Rnd * 90) + 10 '10~99の数値を作成       .Offset(, i).Value = myNum       .Offset(, i + 12).Value = myNum       myNum = Int(Rnd * 90) + 10       .Offset(i).Value = myNum       .Offset(i, 12).Value = myNum     Next   End With   For Each c In Range("O6:X15")     c.Value = Cells(c.Row, "N").Value + Cells(5, c.Column).Value   Next End Sub

関連するQ&A

  • エクセル マクロ:文字変更

    教えてください。 sheet5にデータがあります。 マクロを実行すると、一番右の列のセルに○があると●と書き換える 一番右の列のセルに△があると▲と書き換えるコードを作成しています。 下記のコードでは時間がかかってしまいます。 省略 If Sheets("sheet5").Cells(r, cmax).Value = "○" Then Sheets("sheet5").Cells(r, cmax).Value = "●" 省略 AutoFilterを使用してマクロを作成しましたが、列に○と△が両方無いと 範囲指定したセルがすべて▲となってしまいます。 下記コードをどのように手直ししたらよいのか教えて頂けないでしょうか。 よろしくお願いします。 Sub 文字変更() Dim c As Integer Dim cmax As Integer Dim rmax As Long With Sheets("sheet5") rmax = .Range("A3").End(xlDown).Row cmax = .Range("A3").End(xlToRight).Column .Rows("1:1").Select Selection.AutoFilter For c = 2 To cmax Selection.AutoFilter Field:=c, Criteria1:="○" .Cells(1, c).Offset(1, 0).Select .Range(Selection, Cells(rmax, c)).Value = "●" Selection.AutoFilter Field:=c, Criteria1:="△" .Cells(1, c).Offset(1, 0).Select .Range(Selection, Cells(rmax, c)).Value = "▲" Selection.AutoFilter Field:=c Next c End With Selection.AutoFilter End Sub

  • Excelの目次作成のマクロ

    Excel 2000 で本の目次を作りたいと、思いネットで下記ののようなマクロを見つけました。 Sub 索引作成()   Dim R As Range, R2 As Range, LastFound As Range   Dim Found As Boolean   Range("C2", Range("D65536").End(xlUp).Offset(1, 0)).Clear   For Each R In Range("A2", Range("A65536").End(xlUp))     Found = False     Set LastFound = Range("C65536").End(xlUp)     For Each R2 In Range("C2", LastFound)       If R2.Value = R.Value Then         R2.Offset(0, 1).Value = R2.Offset(0, 1).Value & "," & R.Offset(0, 1).Value         Found = True       End If     Next     If Found = False Then       LastFound.Offset(1, 0) = R.Value       LastFound.Offset(1, 1) = R.Offset(0, 1).Value     End If   Next End Sub このマクロを使うと下記のような結果になるのですが、頁数の桁が多い場合(1000ページ以上)や、項目名の重複が多い場合は上手く動きません。  A    B    C    D 項目名  頁 A     1 B     2 C     3 D     4 A     5 B     6 C     7 D     8   ↓上記マクロを使うと  A    B    C    D 項目名  頁 A     1    A    1,5 B     2    B    2,6 C     3    C    3,7 D     4    D    4,8 A     5 B     6 C     7 D     8 となりますが、頁が1000桁以上になると A B      C     D 項目名  頁 A     1000    A    100,010,04 B     1001    B    100,110,05 C     1002    C    100,210,06 D     1003    D    100,310,07 A     1004 B     1005 C     1006 D     1007 のようになります。 頁が1000桁以上になる場合や、項目名の重複が多くなる場合でも上手く動くマクロは無いものでしょうか。 何卒、宜しくお願いいたします。

  • このマクロあっていますでしょうか?よろしくお願いいたします。

    ★sheetA Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$C$14" And Target.Address <> "$C$19" _ And Target.Address <> "$F$19" Then Exit Sub If Target.Address <> "$R$14" And Target.Address <> "$S$14" _ And Target.Address <> "$T$19" Then Exit Sub Application.EnableEvents = False With Sheets("B") .Range("F14").Value = Range("C14").Value .Range("F17").Value = Range("C19").Value .Range("F20").Value = Range("F14").Value .Range("F23").Value = Range("F19").Value End With With Sheets("C") .Range("F13").Value = Range("R14").Value .Range("F14").Value = Range("S14").Value .Range("F18").Value = Range("T19").Value End With Application.EnableEvents = True End Sub ★sheetB Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$F$14" And Target.Address <> "$F$17" _ And Target.Address <> "$F$23" Then Exit Sub Application.EnableEvents = False With Sheets("A") .Range("C14").Value = Range("F14").Value .Range("C19").Value = Range("F17").Value .Range("F19").Value = Range("F23").Value End With Application.EnableEvents = True End Sub ★sheetC Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$F$13" And Target.Address <> "$F$14" _ And Target.Address <> "$F$18" Then Exit Sub Application.EnableEvents = False With Sheets("A") .Range("R14").Value = Range("F13").Value .Range("S14").Value = Range("F14").Value .Range("T19").Value = Range("F18").Value End With Application.EnableEvents = True End Sub

  • マクロ FIND 検索方向の変更

    いつも回答ありがとうございます。 FINDを使用した検索方向の変更についての質問です。以下のFINDの記述方法で、上から一発目に捉えられたキーワードではなく、下から一発目に捉えられたキーワードに変更するにはどうしたらよろしいでしょうか?それとも、FINDの記述方法を大幅に変えなければいけないのでしょうか?御指導の程宜しくお願い致します。 Sub TEST() Dim d As Integer Dim e As Integer Worksheets("一覧").Activate d = 3 e = 3 Do While Worksheets("一覧").Cells(d, 2).Value <> "" Dim c As Variant Dim R As Range Dim s As Range With Worksheets(Worksheets("一覧").Cells(d, 2).Value) Set c = .Columns("H").Find("増", , xlValues, 1) If Not c Is Nothing Then Set R = .Range(c.Offset(1, -4), .Cells(Rows.Count, "D").End(xlUp)) Set s = c.Offset(, -5) With Worksheets("編集用一覧") .Range(.Cells(e, 4), .Cells(e, 5)).ClearContents .Cells(e, 4).Value = s .Cells(e, 5).Value = Application.Sum(R) End With End If End With d = d + 1 e = e + 4 Loop End Sub

  • ほんの少し変更しただけで、マクロが正常動作しないのは?

    「てすと1」はきちんと、結果が反映されるが、 「てすと2」は、動作はするが、肝心のデータがコピーされません。 Range("B5", Range("B5").End(xlDown)) と、変更しただけです。 ただ、「てすと2」は、手動で Worksheets(i)をアクティヴにしておくと、きちんと結果が反映されます。 なぜなんでしょうか? 何卒、ご教授お願い致します。 Sub てすと1() Dim i As Integer   Windows("TEST.xls").Activate   Sheets.Add after:=Worksheets(Worksheets.Count), Count:=1 On Error Resume Next For i = 1 To Worksheets.Count - 1   Worksheets(i).Range("C:C").Copy _   Destination:=Worksheets(Worksheets.Count).Range("IV4").End(xlToLeft).Offset(0, 1).EntireColumn  Next i End Sub Sub てすと2() Dim i As Integer   Windows("TEST.xls").Activate   Sheets.Add after:=Worksheets(Worksheets.Count), Count:=1 On Error Resume Next For i = 1 To Worksheets.Count - 1   'Worksheets(i).Activate  '左記を追記すると、きちんと結果が反映される   Worksheets(i).Range("B5", Range("B5").End(xlDown)).Copy _   Destination:=Worksheets(Worksheets.Count).Range("IV4").End(xlToLeft).Offset(0, 1)  Next i 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 宜しくお願い致します。

  • 2つのマクロを1つにしたい

    いつもお世話になっております。 今回もよろしくお願いいたします。 (1)14のシートがあるのですが、データーのある2から14までのシートを印刷する。 (2)上記のうち、c列のデーターで連続しているセルを結合する。 (1)と(2)を合わせて1つのマクロにしたいのですが、アクティブシート1つにしか(2)のマクロが動きません。 下記のコードの間違いを教えてください。 Sub 契約書目次印刷() Dim Sh As Worksheet Dim t As Long Dim i As Range t = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row 'データーのあるシートだけ印刷 For Each Sh In Worksheets(Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14)) If Sh.Range("A2").Value <> "" Then '連続データーセル結合 For Each i In Range("C1:C" & t) If i.MergeArea(1).Value = i.Offset(1).Value Then Range(i.MergeArea, i.Offset(1)).Merge End If Application.DisplayAlerts = False Next i End If Sh.PrintPreview Next Sh End Sub

  • エクセルの簡単なマクロ機能を追加したいのです

    既存のエクセルマクロ(Sub チェック()以下です)に下記の内容のマクロを付け足したいです。 教えていただけないでしょうか。 付け足したい条件です:  Sheet2のC列に 0  があれば  Sheet1のB列に 愛 と([太字]でセルの背景色を[灰色25%]にして)入れたいです 恐れ入りますがご存じの方がいらっしゃりましたら教えていただきたく何卒よろしくお願いいたします。 ----------------------------------------------- Sub チェック() Dim Ws1 As Worksheet Dim Ws2 As Worksheet Dim myRange1 As Range Dim myRange2 As Range Dim c1 As Range Dim c2 As Range Dim myCt As Long Set Ws1 = Worksheets("Sheet1") Set Ws2 = Worksheets("Sheet2") Set myRange1 = Ws1.Range("A1", Ws1.Cells(Rows.Count, "A").End(xlUp)) Set myRange2 = Ws2.Range("A1", Ws2.Cells(Rows.Count, "A").End(xlUp)) For Each c1 In myRange1 myCt = 0 For Each c2 In myRange2 If c2.Value = c1.Value Then If c2.Offset(, 1).Value = "" Then c1.Offset(, 1).Interior.ColorIndex = 3 Else c1.Offset(, 1).Value = c2.Offset(, 1).Value End If myCt = myCt + 1 End If Next c2 If myCt > 1 Then c1.Offset(, 1).Interior.ColorIndex = 10 Next c1 Set Ws1 = Nothing Set Ws2 = Nothing Set myRange1 = Nothing Set myRange2 = Nothing End Sub

  • ExcelVBA .cells(… が働きません

    お世話になります メモリーの、壁と 格闘して、います 其の、中で OfficeTANAKA様の http://officetanaka.net/excel/vba/tips/tips71.htm の、ページを 拝見し Private Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS) と、モジュールに、 書き加えた、ところ With Ws   ↓此処、メソットがダメ  With .Range(.cells(… が、突如エラーに なり始めました Private Declare S… を、外して 全て、元通りに しても 回復、しません 回復可能で、しょうか? 宜しく お願い、します                  記 Option Explicit Option Base 0 Private Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS) '↑  ↑  ↑  ↑ '此れを、加えると Type 変数取得順速度差を減らす  s1 As Long  s2 As Long  Ch As Long  du As Long  St As String  Rg As Range End Type Const n As Long = 2000 Dim lp As 変数取得順速度差を減らす, Data(1 To n, 1 To n) As Long, k As Long, Ws As Worksheets Sub ダミーデータ作成1()  Set Ws = Worksheets.Add()  Worksheets("Sheet1").Select  With Ws’   ↓此処で、エラー   With .Range(.Cells(1, 1), .Cells(n, n))    Let lp.St = "Min(" & Ws.Name & "!" & .Address & ")"   End With   For k = 0 To Int(n / 100) - 1    For lp.s2 = 1 To 100     For lp.s1 = 1 To n      With .Cells(k * 100 + lp.s2, lp.s1)       .Formula = "=RANDBETWEEN(1," & n & ")"       .Calculate       .Value = .Value       Data(k * 100 + lp.s2, lp.s1) = .Value      End With     Next lp.s1    Next lp.s2    Worksheets("Sheet1").Range("c1").Value = k    Application.DisplayAlerts = False    ThisWorkbook.Save    Application.DisplayAlerts = True   Next k   Set lp.Rg = .Range(.Cells(1, 1), .Cells(n, n))  End With End Sub                              以上

  • ExcelVBA データのコピー範囲について

    あけましておめでとうございます。今年もよろしくお願いします。 Sub Test() Dim myTarget As Range, r As Range, f Set myTarget = Sheets("Sheet1"). _    Range("B2", Sheets("Sheet1").Range("B65536").End(xlUp)) For Each r In myTarget  Set f = Sheets("Sheet2").Columns(1). _    Find(r.Value, Sheets("Sheet2").Range("A1"), Lookat:=xlWhole)  If Not f Is Nothing Then    If r.Offset(0, 3).Value <> f.Offset(0, 3).Value Then      f.Resize(1, 4).Copy Destination:= _      Sheets("Sheet3").Range("A65536").End(xlUp).Offset(1, 0)    End If  End If Next r End Sub 前回の質問で教えていただいたコードなのですが、現時点では、B列のデータを元にして二つのSheetのデータを比較して別Sheetへコピーしているのですが、そのときに、B列以降の(たとえば、B列からX列まで)データはコピーできますが、A列もコピーしたい時はどうすればよいのかで、悩んでいます。どの様に変更すればよいのでしょうか?