• ベストアンサー

VBAで変数が使いこなせなくて、困っています

エクセル VBAで、 「業者コードを入力すると、業者の名前と電話番号を表示してくれる。」 というVBAを、本を見ながら作ったのですが、(下にコピペしました↓) これだと業者コードが増える度、VBAに入力していかなければならないことに。 業者さんはどんどん増えていくので、追いつかなく困っています。 iを使ったり応用しようとしましたが、自力ではどうも無理なのです。 初めてなので、説明不足でしたらすみません。 どうかお願いします! ------------------------------------------------------------ Sub 業者コードから入力() ' Dim getstr As String Dim msg As String Dim title As String Set ws1 = Worksheets("データ") Set ws2 = Worksheets("業者コード") Set ws3 = Worksheets("通知書") msg = "業者コードを入力してください" title = "コード入力" getstr = InputBox(msg, title) getstr = UCase(getstr) Select Case getstr Case "00" ws3.Range("d6") = ws2.Range("e7") ws3.Range("d9") = ws2.Range("i7") ws3.Range("q9") = ws2.Range("j7") Case "01" ws3.Range("d6") = ws2.Range("e8") ws3.Range("d9") = ws2.Range("i8") ws3.Range("q9") = ws2.Range("j8") Case "02" ws3.Range("d6") = ws2.Range("e9") ws3.Range("d9") = ws2.Range("i9") ws3.Range("q9") = ws2.Range("j9") Case "03" ws3.Range("d6") = ws2.Range("e10") ws3.Range("d9") = ws2.Range("i10") ws3.Range("q9") = ws2.Range("j10") Case "04" ws3.Range("d6") = ws2.Range("e11") ws3.Range("d9") = ws2.Range("i11") ws3.Range("q9") = ws2.Range("j11") Case "05" ws3.Range("d6") = ws2.Range("e12") ws3.Range("d9") = ws2.Range("i12") ws3.Range("q9") = ws2.Range("j12")   Case Else     MsgBox "エラーです" End Select End Sub ------------------------------------------------------------

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

  • ベストアンサー
回答No.2

Sub 業者コードから入力() Dim getstr As String Dim msg As String Dim title As String Dim iRange As Integer Set ws1 = Worksheets("データ") Set ws2 = Worksheets("業者コード") Set ws3 = Worksheets("通知書") msg = "業者コードを入力してください" title = "コード入力" getstr = InputBox(msg, title) getstr = UCase(getstr) iRange = Int(getstr) + 7 'コードを数値化しています '00が7行目のデータのようなので7を足しています ws3.Range("d6") = ws2.Range("e" & iRange) ws3.Range("d9") = ws2.Range("i" & iRange) ws3.Range("q9") = ws2.Range("j" & iRange) End Sub ------------------------------------------------- ws3.Range("d6") = ws2.Range("e7") ws3.Range("d9") = ws2.Range("i7") ws3.Range("q9") = ws2.Range("j7") を見ると左辺のRange("d6")Range("d9")Range("q9") は固定で 右辺のセルの数値が上がっているのでそこの部分を変数で置き換えてみてはいかがでしょうか? 上記ではiRangeというInteger型の変数でおいてみました。 こんな感じでいけるのではないでしょうか?

kinoyasuko
質問者

お礼

できました!! わあああ、ありがとうございます!!! 変数もっと勉強しまする。。 こんなに早く解決するとは、、 とても助かりました。ありがとうございました。

その他の回答 (1)

回答No.1

前提条件 1行に事業者のデータがおさまっていること。 余分なデータが入っていないこと。 ----------------------------------------------------------- Dim intMaxRow As Integer Dim intIndex As Integer 'データが入力されている最後の行を検索 intMaxRow = ActiveSheet.UsedRange.End(xlDown).Row For intIndex = 1 To intMaxRow '事業者番号検索を抜ける条件(空白のセルが見つかったら) If Sheet2.Cells(intIndex, 1) = "" Then Exit For End If If getstr = Sheet2.Cells(intIndex, 0) Then 'ここに一致した場合の処理 End If Next ----------------------------------------------------------- For文の1は開始行です。 Cellsの引数になっている1は列番号です。 コードから推測するにFor文の1を7に、Cellsの引数の1を5にすればいけると思います。

kinoyasuko
質問者

お礼

迅速なご回答、ありがとうございます! 早速やってみたのですが、エラーがでてしまい・・ 超初心者なので、適応できませんでした。。

関連するQ&A

  • エクセル VBAの作成について

    初心者なりに、色々参考にさせてもらいながらエクセル・VBAで、 顧客データと業者コードに入力した数字や文字列を 顧客Noを入力すると請求書に表示される、というVBAを作ったのですが、顧客データの並び順が表に反映されてしまいます、 (例えば顧客NoがNo5だと請求書10行目から順に表示したいのに、13行目に表示されてしまいます。No4だと12行目、No3だと11行目という風に・・) ws1の、顧客データは、10行目から順に1行ずつ下がって入力したいけど、 ws2の、業者コードの情報は3行目のまま固定して表示したいのです。 こんな場合どうすればいいでしょうか・・? 説明足りなければ申し訳ありません。。 下に、自分で作ったVBA張っておきます。↓   Sub 請求書作成() Dim getstr As String Dim msg As String Dim title As String Dim irange As Integer Dim iirange As Integer  Set ws1 = Worksheets("顧客データ")  Set ws2 = Worksheets("業者コード")  Set ws6 = Worksheets("▲請求書▲") msg = "顧客NO.を入力してください" title = "NO.入力" getstr = InputBox(msg, title) getstr = UCase(getstr)   irange = Int(getstr) + 4   iirange = Int(getstr) + 8  ws6.Range("a4") = ws1.Range("g" & irange)  ws6.Range("d3") = ws1.Range("j" & irange) EndRow = Cells(ws6.Rows.Count, 8).End(xlUp).Row  ws6.Range("c" & iirange) = ws1.Range("l" & irange)  ws6.Range("f" & iirange) = ws1.Range("c" & irange)  ws6.Range("n" & iirange) = ws1.Range("bf" & irange)  ws6.Range("v" & iirange) = ws1.Range("dh" & irange)  ws6.Range("ab" & iirange) = ws1.Range("ac" & irange)  ws6.Range("aw" & iirange) = ws1.Range("dz" & irange)  ws6.Range("ah" & iirange) = ws2.Range("l" & irange + 2) End sub

  • COUNTIFS関数をVBAで使用したい

    お世話になります。 よろしくお願いいたします。 Sheet1に集計表、Sheet2にデーターがあります。 氏名とコードが合致するデーターの個数を出したいのですが、コードの書き方がわかりません。 ご教示をお願いいたします。 Sheet1のB列の最後に小計や合計が入っているため、A列使用。 COUNTIFS関数でコンパイルエラーがでます。 Sheet1 A    B   C    D 氏名 氏名 コード 合致する個数 Sheet2 B    J     N 氏名  コード   数値 Sub test1() Dim i As Long, t As Long Dim wS1 As Worksheet, wS2 As Worksheet Set wS1 = Worksheets("Sheet1") Set wS2 = Worksheets("Sheet2") i = wS1.Range("A" & Rows.Count).End(xlUp).Row t = wS2.Range("B" & Rows.Count).End(xlUp).Row Application.ScreenUpdating = False For i = 5 To i Range(wS1.Cells(5, "D"), wS1.Cells(i, "D")).Formula = _ "=COUNTIFS(wS2.Range("B7:B"&t),B5,wS2.Range("J5:J"&t),C5)" Next i Application.ScreenUpdating = True End Sub

  • エクセル VBA

    VBA内で、そのVBAの実行を制御することは可能でしょうか? 下のようなコードを作ったのですが、 Sub 承認書作成() Dim ws0 As Worksheet, ws1 As Worksheet, r1 As Range Dim i As Long Dim nyuryoku(), chikuseki() Set ws0 = Worksheets("承認書作成") Set ws1 = Worksheets("顧客データ") Set ws2 = Worksheets("業者コード") Set ws3 = Worksheets("承認通知書") Worksheets("顧客データ").Select Range("テーブル1[[#Headers],[NO.]]").Select Selection.End(xlToRight).Select Selection.End(xlDown).Select Selection.ListObject.ListRows.Add AlwaysInsert:=False Range("B7").Select nyuryoku = Array("b5", "d5", "f5", "h5", "j5", "l5", "n5", "p5", "b6", "d6", "f6", "h6", "j6", "l6", "n6", "p6", "b4", "d4") '転記したいセルの位置 chikuseki = Array("0", "1", "5", "6", "8", "9", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "53", "54") '転記先の列のオフセット値  Set r1 = ws1.Range("f" & Rows.Count).End(xlUp).Offset(0) 'データ蓄積セル  For i = 0 To UBound(nyuryoku) r1.Offset(0, chikuseki(i)).Value = ws0.Range(nyuryokui)).Value '入力 Next MsgBox "入力完了" Dim lRowNum As Long '転記先となる行番号を求める lRowNum = ws1.Cells(Rows.Count, "b").End(xlUp).Row '転記 ws3.Cells(6, "d").Value = ws1.Cells(lRowNum, "j").Value ws3.Cells(17, "g").Value = ws1.Cells(lRowNum, "c").Value ws3.Cells(22, "g").Value = ws1.Cells(lRowNum, "l").Value ws3.Cells(22, "ac").Value = ws1.Cells(lRowNum, "ab").Value    Set ws0 = Nothing   Set ws1 = Nothing End Sub ここに、     If call Macro1 then call 承認書作成  '上のマクロです    Else: Msgbox"中止" 「Macro1を実行しないと承認書作成マクロを実行できない」 という コードを組み込みたいのですが、うまくいきません。 VBA内に同じVBAを組み込むことは不可能なのでしょうか?

  • ExcelのVBAについて(勉強中のです。)

    ExcelのVBAについて(勉強中のです。) ここからコード3以降に入力したコードを抜き出してデータ表を作成しそれを保存するコードを作成したいです。例えばCSV形式にするとか? データ表は1日分の表示で、保存して週間や月間または統計データまでを視野にいれています。今回は保存する所です。。 利用しやすい状態と保存形式で、よろしくお願いします。データは生活記録みたいなものです。何したどうしたどうなった? ※大分分岐する予定で、作成中であり、今回はコードの整理は不要です。 '///Sheet1/// Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim time7 As Range For Each time7 In Target If time7.Column = 1 Then time7.Offset(0, 4).Value = Format(Now, "Short Time") & vbCrLf & _ Format(Now, "yyyy/mm/dd hh:nn:ss AM/PM") End If Application.EnableEvents = False Application.EnableEvents = True Next time7 '(1)シートを変数にセット Dim ws1 As Worksheet Dim ws2 As Worksheet Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") '(2)シートを指定してデータを転記 ws2.Range("A3:H3").Value = ws1.Range("A3:H3 ").Value End Sub Private Sub Worksheet_Activate() ' ' 新規行挿入 ' ' Worksheets("Sheet2").Range("3:3").Insert Sheets("Sheet1").Range("H3").Select ActiveCell.FormulaR1C1 = "5" Sheets("Sheet1").Range("E3").Select Selection.ClearContents Dim str_Left As String 'セルE4に文字列、セルH4に数字を予め入れておくこと。 str_Left = Left(Cells(4, 5), Cells(4, 8)) MsgBox str_Left & vbCrLf & " " & "OKボタンを押してください!" Sheets("Sheet1").Range("A3").Select Dim se_r As String se_r = Application.InputBox("バーコードを入力してください") Select Case se_r Case "False" MsgBox "キャンセルされました" Case "" MsgBox "空欄が入力されました" Case Else Range("A3").Value = se_r End Select End Sub ' ///Sheet2/// Private Sub Worksheet_Activate() Dim Emp(1 To 300) As String Dim msg As String Dim i, i2, Cnt As Integer Dim N_In As Variant For i = 3 To 3 If IsEmpty(Cells(i, 1).Value) = False Then 'ここで空欄判定 Worksheets("Sheet1").Range("3:3").Insert '対象セルアドレスを改行処理 End If Next i '(1)シートを変数にセット Dim ws1 As Worksheet Dim ws2 As Worksheet Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") ws1.Activate End Sub

  • ExcelのVBAについてです。シート1と2を作成

    ExcelのVBAについてです。シート1と2を作成し、シート1にバーコードまたはキーボードで入力します。シート1は入力専用かつ入力した分の早見表で、実際にはシート2に転記仕訳して、シート3以降に表を作成したいです。使い方はシート1に入力またはシート2をタップまたはクリックすると入力(画面)になります。以前の質問の回答を参考に必要最低限に改良しています。パッと見で構いません、何か不具合は見付からないでしょうか? '///Sheet1/// Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim time7 As Range For Each time7 In Target If time7.Column = 1 Then time7.Offset(0, 4).Value = Format(Now, "Short Time") & vbCrLf & _ Format(Now, "yyyy/mm/dd hh:nn:ss AM/PM") End If Application.EnableEvents = False Application.EnableEvents = True Next time7 '(1)シートを変数にセット Dim ws1 As Worksheet Dim ws2 As Worksheet Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") '(2)シートを指定してデータを転記 ws2.Range("A3:H3").Value = ws1.Range("A3:H3 ").Value End Sub Private Sub Worksheet_Activate() ' ' 新規行挿入 ' ' Worksheets("Sheet2").Range("3:3").Insert Sheets("Sheet1").Range("H3").Select ActiveCell.FormulaR1C1 = "5" Sheets("Sheet1").Range("E3").Select Selection.ClearContents Dim str_Left As String 'セルE4に文字列、セルH4に数字を予め入れておくこと。 str_Left = Left(Cells(4, 5), Cells(4, 8)) MsgBox str_Left & vbCrLf & " " & "OKボタンを押してください!" Sheets("Sheet1").Range("A3").Select Dim se_r As String se_r = Application.InputBox("バーコードを入力してください") Select Case se_r Case "False" MsgBox "キャンセルされました" Case "" MsgBox "空欄が入力されました" Case Else Range("A3").Value = se_r End Select End Sub ' ///Sheet2/// Private Sub Worksheet_Activate() Dim Emp(1 To 300) As String Dim msg As String Dim i, i2, Cnt As Integer Dim N_In As Variant For i = 3 To 3 If IsEmpty(Cells(i, 1).Value) = False Then 'ここで空欄判定 Worksheets("Sheet1").Range("3:3").Insert '対象セルアドレスを改行処理 End If '(1)シートを変数にセット Dim ws1 As Worksheet Dim ws2 As Worksheet Dim st1, s, i3 As Long Dim Bst As Range Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") '(2)シートを指定してデータを転記 st1 = ws1.Cells(Rows.Count, "E").End(xlUp).Row 'A列の最終行を設定する s = 3 For i3 = 3 To st1 Set Bst = ws2.Columns("E").Find(What:=ws1.Cells(i3, "E"), LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) シート間のE列を比較 If Bst Is Nothing Then '比較して無い場合は、下記を実行 ws1.Cells(s, "A") = ws1.Cells(i3, "A") '追加する文字を転記する。(コード) s = s + 1 End If Next i3 Next i '(1)シートを変数にセット Dim ws1_ As Worksheet Set ws1_ = Worksheets("Sheet1") ws1_.Activate End Sub

  • Excel VBA 連番印刷

    昨日以下の質問をさせていただいた者です。 http://okwave.jp/qa/q8349562.html こちらで教えていただいた以下のコードに、 J2のセルに連番を振るコードを付け足したいと思い、 同じくこちらのサイトの過去の履歴にあった以下コードを参考にとやってみているのですが、 Next で指定された変数の参照が無効です。と言われてしまいます… 印刷部数の指定はいらず、sheet印刷のJ2セルに1から始まる連番を振りたいのです。 どのように修正をしたらいいのかご教示願います。 Sub Sample4() Dim i As Long, endRow1 As Long, endRow2 As Long, myArea1 As Range, myArea2 As Range Dim wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet Set wS1 = Worksheets("DB") Set wS2 = Worksheets("印刷") Set wS3 = Worksheets("Sheet3") endRow1 = wS1.Cells(Rows.Count, "A").End(xlUp).Row Range(wS1.Cells(1, "A"), wS1.Cells(endRow1, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True wS1.Range("A:A").Copy wS3.Range("A1") wS1.ShowAllData For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row If endRow2 > 9 Then Range(wS2.Cells(10, "B"), wS2.Cells(endRow2, "H")).ClearContents Range(wS2.Cells(10, "J"), wS2.Cells(endRow2, "J")).ClearContents End If wS1.Range("A1").AutoFilter field:=1, Criteria1:=wS3.Cells(i, "A") wS2.Range("B6") = wS3.Cells(i, "A") Set myArea1 = Range(wS1.Cells(2, "B"), wS1.Cells(endRow1, "H")).SpecialCells(xlCellTypeVisible) Set myArea2 = Range(wS1.Cells(2, "I"), wS1.Cells(endRow1, "I")).SpecialCells(xlCellTypeVisible) myArea1.Copy wS2.Activate ActiveSheet.Range("B10").Select Selection.PasteSpecial Paste:=xlPasteValues myArea2.Copy wS2.Activate ActiveSheet.Range("J10").Select Selection.PasteSpecial Paste:=xlPasteValues endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row 'Range(wS2.Cells(1, "A"), wS2.Cells(endRow2, "J")).PrintOut Next i wS1.AutoFilterMode = False wS3.Cells.Clear End Sub 連番印刷のコード Sub NumberPrint() Dim idx As Integer Dim res  res = Application.InputBox("印刷部数を入力してください", Type:=1)  If res > 0 Then   For idx = 1 To res    Range("AW3").Value = idx    ActiveSheet.PrintOut   Next idx  End If End Sub

  • vba 曜日のデータ

    どなたか教えて頂ければ幸いです。 以下のようなコードがあります。これは、1~31迄の日付シートに あらかじめ用意されている日~土までの曜日シートの内容を 自動的にコピーしようとしているものです。 日付シートのB5には weekday()関数とユーザー定義の書式のaaaにより 日曜日なら「日」、月曜日なら「月」が入っています。 ですが、下の「<------」の箇所は、エラーではありませんが、 一致確認がなされていません。weekday()関数の戻り値を文字列と して見ていないのでしょうか? Sub test() Dim ws As Worksheet Dim i As Integer For Each ws In Worksheets  For i = 1 To 31   If ws.Name = CStr(i) Then   ws.Select    If ws.Range("B5") = "日" Then      <-----     Worksheets("日").Range("A1:D3") _       .Copy Destination:=ws.Range("A7")       ws.Tab.ColorIndex = 45    ElseIf ws.Range("B5") = "月" Then    <-----     Worksheets("月").Range("A1:D3") _     .Copy Destination:=ws.Range("A7")     ws.Tab.ColorIndex = xlNone

  • オブジェクト??

    またまた困っております inputboxで入力した日付を検索して複数選択しようとしたのですが unionの使い方がよくわかりません(・・;) どこが間違っているのかもしくは何が足りないのか教えてください<m(__)m> どうかよろしくお願いします! Option Explicit Sub グラフ() Const SH_NAME As String = "VBA" Dim art As String Dim i Dim ws As Worksheet Dim endrow As Long Dim msg As String Dim writerow As Integer Dim grahu As Chart Dim target As Range Set ws = ThisWorkbook.Worksheets(SH_NAME) writerow = 2 art = InputBox("日付を入力してください") With ws endrow = .Cells(Rows.Count, 2).End(xlUp).Row For i = 2 To endrow If art = .Range("A" & i) Then Set target = Union(target, "D" & i) Else If InStr(msg, .Range("A" & i)) = 0 Then msg = msg & .Range("A" & i) & vbCrLf End If End If Next i target.Select End With If msg <> "" Then MsgBox msg End If MsgBox "グラフベースを作成しました" End Sub Set target = Union(target, "D" & i) ↑ここでエラーが起きて 「オブジェクトが必要です」と言われました どうすればよいのでしょうか?

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

    下記のようなプログラム組んでいます。 Sub 張付() Sheets("一覧表").Select Dim i As Long Dim ws1, ws2 As Worksheet Set ws1 = Worksheets("一覧表") Set ws2 = Worksheets("データー") For i = 5 To ws2.Cells(Rows.Count, 1).End(xlUp).Row ws1.Range("B5") = ws2.Cells(i, 2)    'セルB5に氏名を入力 ws1.Range("C5") = ws2.Cells(i, 3)    'セルC5に年齢を入力 ws1.Range("D5") = ws2.Cells(i, 4)    'セルD5に電話番号を入力 この後、 ws1.Range("B5")のB5をB6にまた、C5はC6に改行してそれぞれデーターを移していきたい のですが、B5をB6に順次プラスする方法を教えて下さい。 よろしくお願いいたします。

  • vba変数のファイル名

    Cells(2, 3)にjを変数として、j.txtと書きたいのですが上手くいきません。 わかる方教えてください。 コードは以下のようになっています。よろしくお願いします。 Dim j As Integer For j = 1 To 8760 a = ThisWorkbook.Worksheets("Sheet2").Cells(j, "A").Value Worksheets("Sheet1").Range("1:26").Insert Worksheets("Sheet1").Cells(1, 1) = "void brightdata sky_dist" Worksheets("Sheet1").Cells(2, 1) = 7 Worksheets("Sheet1").Cells(2, 2) = "corr" Worksheets("Sheet1").Cells(2, 3) = " & j & ".txt” Next j