• 締切済み

エクセル　VBA　リストボックスからの動きについて

エクセルでどうにかできないかと悩んでおります。 自分一人ではいいアイデアが浮かばないので皆様のお知恵を拝借いたしたく出させていただきます。 Private Sub CommandButton1_Click() With ListBox1 For i = 0 To .ListCount - 1 Windows("元データ.xls").Activate If .Selected(i) = True Then a = Cells(i + 2, 1) b = Cells(i + 2, 2) Windows("書き込みたいファイル.xls").Activate With Range("A20").End(xlDown).Offset(1, 0) .Offset(0, 0) = a .Offset(0, 2) = b という形で作っていますが、よく考えると『書き込みたいファイル』は 名前が色々変わってしまうファイルになっているので、それでも動くようにしたいのです。 上記2種類のファイル以外を閉じてしまう・・・という形は自分でも考えたのですが、 特定多数の人間が使うため、あまり制限をかけた状態では使いたくないのが現状です。 出来れば他のファイルを閉じたりしないようにしたいと思います。 皆様のお知恵をいただければ幸いと思いますので宜しくお願いいたします。

  • nanny
  • お礼率55% (72/129)

みんなの回答

  • Masa2072
  • ベストアンサー率51% (94/182)
回答No.1

まずはこのマクロはどのブックに記述されているのでしょうか？ 元データ.xlsに存在するのであれば、ボタンをクリックする前にシートなりフォーム上なりにファイル名を記録しておく。 書き込みたいファイル.xlsに存在するのであれば、Thisworkbookを使うとか・・・ 全く関係ない話ですが、windows("書き込みたいファイル名").Activate という書き方では、該当ブックにシートが1枚ならともかく複数シートがあった場合、意図した場所にデータの書き込みが出来ない恐れがあります。 Workbooks("書き込みたいファイル名.xls").Sheets("Sheet1").Activate といった書き方のほうがよいと思います。

  1. カテゴリ
  2. パソコン・スマートフォン
  3. ソフトウェア
  4. オフィス系ソフト

関連するQ&A

  • Excel VBA リストボックスについて

    現在エクセルのVBAを勉強中の 超初心者なのですが、 リストボックスを使うコードでエラーが出て どう直したらいいかわかりません。 下記コードをどのようになおしたらいいでしょうか？ 回答、よろしくお願いいたします。 エラー内容は、実行時エラー381 Listプロパティを設定できません。プロパティの配列のインデックスが無効です。 Private Sub UserForm_Initialize() 'リストボックスの設定 With ListBox1 .Font.Size = 10 .ColumnCount = 7 .ColumnWidths = "50;100;80;80;100;30;70" .TextAlign = fmTextAlignLeft .Font.Name = "MSゴシック" End With Dim i As Integer Dim LastRow As Integer LastRow = Range("A" & Rows.Count).End(xlUp).Row For i = 2 To LastRow With ListBox1 .AddItem Cells(i, 1).Value .List(ListCount - 1, 1) = Cells(i, 2).Value .List(ListCount - 1, 2) = Cells(i, 3).Value　←ここでエラー .List(ListCount - 1, 3) = Cells(i, 4).Value .List(ListCount - 1, 4) = Cells(i, 5).Value .List(ListCount - 1, 5) = Cells(i, 6).Value .List(ListCount - 1, 6) = Cells(i, 7).Value End With Next End Sub

  • エクセルVBA　セルのコピー＆ペーストで・・・

    A1のセルに、１２３ B2のセルに、４５６ C3のセルに、７８９ とある　A.xlsファイルがあるとして B.xlsファイルの A4のセルに１２３ B4のセルに４５６ C4のセルに７８９とコピーしたいのです・・・と ここまでは出来たのですが、ここからが悩み所で、 上記の状況で、A4～C4までにはデーターが入っているので、次はその下のA5～C5までにデーターを入れたいのです。 A.xlsのデーター入力部分は一緒で、B.xlsのペースト部分は、入力していないセルの一番上にペーストしたいのです。 ちなみにちょっと作ってみましたがだめでした；； Windows("A.xls").Activate DATA = Range("A1:N100") Windows("B.xls").Activate With Cells(4, 1).End(xlDown).Offset(1, 0) = DATA(1, 1) っていうような感じで作ってみたのですが動かないです；； よろしくお願い致します

  • VBA　リストボックスについて

    VBA初心者です。どうぞよろしくお願いします。 ユーザーフォームにタブつきのリストボックスを作りたいと思っています。 リストはsheet1の中にあります。 　　A　　　　B　　　　C　　　　D・・・ 1　　NO　　品名　　売場 2　　1　　いちご　　果物 3　　2　　みかん　　果物 4　　3　　もも　　　　果物 5　　4　　ハクサイ　野菜 6　　5　　キャベツ 　野菜 7　　6　　きゅうり　　野菜 8　　7 9 果物のタブには、果物の品名が表示される。 1 いちご 2 みかん 3 もも 野菜のタブには、野菜の品名が表示される。 4 ハクサイ 5 キャベツ 6 きゅうり 青果のタブには、果物、野菜が表示される。 1 いちご 2 みかん 3 もも 4 ハクサイ 5 キャベツ 6 きゅうり 本を見ながら格闘しておりますが、きっと的違いで滅茶苦茶なことをしているのだと思います。 どうにも出来ず困っております。どなたか教えていただけないでしょうか。よろしくお願いします。 Private Sub UserForm_Initialize() Dim LastRow As Long Dim i As Integer Dim ListBoxNo As Integer Dim ListBox As Control Dim Listtabu(3) As Long 'タブの数 For i = 1 To 3 Listtabu(i) = 0 Next i Worksheets("sheet1").Activate With Worksheets("sheet1") LastRow = .Range("A65536").End(xlUp).Row For i = 2 To LastRow If Worksheets("sheet1").Range(Cells(i, 3)) = "果物" Then ListBoxNo = 1 Set ListBox = 果物 果物.List = Worksheets("sheet1").Range(Cells(i, 1), Cells(i, 2)).Value End If If Worksheets("sheet1").Range(Cells(i, 3)) = "野菜" Then ListBoxNo = 2 Set ListBox = 野菜 野菜.List = Worksheets("sheet1").Range(Cells(i, 1), Cells(i, 2)).Value End If If Worksheets("sheet1").Range(Cells(i, 3)) = "果物" & "野菜" Then ListBoxNo = 3 Set ListBox = 青果 青果.List = Worksheets("sheet1").Range(Cells(i, 1), Cells(i, 2)).Value End If ListBox.AddItem ListBox.List(Listtabu(LstBxNo), 0) = Worksheets("sheet1").Cells(i, 1).Value ListBox.List(Listtabu(LstBxNo), 1) = Worksheets("sheet1").Cells(i, 2).Value Listtabu(LstBxNo) = Listtabu(LstBxNo) + 1 Next End With End Sub

  • エクセルVBAで無限ループ

    教えてください。 以下の２つのエクセルマクロはまったく同じことをさせようとしているのですが、test02の方は.Offset(1).Activateが働かないのか、無限ループに陥ってしまいます。 単にActiveCell.という記述をWith～End Withでまとめただけなのになぜこうなるのでしょうか？ Sub test01() ActiveSheet.Cells(1, 1).Activate Do While ActiveCell.Value <> "" If Not IsNumeric(ActiveCell.Value) Then ActiveCell.Offset(0, 1).Value = "文字" ElseIf ActiveCell.Value > 0 Then ActiveCell.Offset(0, 1).Value = "正数" ElseIf ActiveCell.Value < 0 Then ActiveCell.Offset(0, 1).Value = "負数" Else ActiveCell.Offset(0, 1).Value = "その他" End If ActiveCell.Offset(1).Activate i = i + 1 Application.StatusBar = i Loop End Sub Sub test02() ActiveSheet.Cells(1, 1).Activate With ActiveCell Do While .Value <> "" If Not IsNumeric(.Value) Then .Offset(0, 1).Value = "文字" ElseIf .Value > 0 Then .Offset(0, 1).Value = "正数" ElseIf ActiveCell.Value < 0 Then .Offset(0, 1).Value = "負数" Else .Offset(0, 1).Value = "その他" End If .Offset(1).Activate i = i + 1 Application.StatusBar = i Loop End With End Sub

  • ＶＢＡ　他のエクセルファイルデータを読み込む

    エクセルのＶＢＡに関する質問です。 かじった程度の知識でがんばってはみたのですが、以下のことがどうしてもできません。 集計ファイルと、それぞれが入力するファイルがいくつか（具体的には１Ａ.xls、１Ｂ.xls、２Ａ.xls、２Ｂ.xlsといった数字とアルファベットの組み合わせ）あります。 入力ファイルに書かれているデータを集計ファイルに取り込もうと考えています。 入力ファイル名が（１.xls，２.xls・・・）の様に数字だけの取り込みはできました。 m = Val(UserForm2.TextBox1.Text) For i = 1 To m On Error GoTo myError Workbooks.Open Filename:="C:" & i & ".xls", UpdateLinks:=0 Range("f65536").End(xlUp).Activate Workbooks(i & ".xls").Activate Sheets("入力ファイル").Select Range("A3:X52").Select Application.CutCopyMode = False Selection.Copy Workbooks("集計ファイル.xls").Activate Sheets("DB").Activate Range("a65536").End(xlUp).Activate Selection.Offset(1).Select ActiveSheet.Paste Range("a65536").End(xlUp).Select 　　Workbooks(i & ".xls").Close SaveChanges:=False myError: Next i Application.DisplayAlerts = True こんな感じです。 これを、数字だけでなく数字＋アルファベット.xlsのファイル名にしてデータを取り込むにはどうすればいいのでしょうか？色々と試行錯誤をしたり、ネットで調べたりしたのですが、詰んでしまいました。 どなたかお助け下さい。

  • リストボックスの内容を検索したいが...

    エクセル2019を使っています。 添付画像のようにユーザーフォームにテキストボックスとリストボックスを作り、テキストボックスに入力した文字でリストボックスの内容を検索しようとコードを作成しました。 Private Sub TextBox1_Change() Dim LastRow As Integer Dim rng As Range, r As Range With Worksheets("Sheet1") If .AutoFilterMode <> True Then .Range("A1").AutoFilter End If LastRow = .Cells(Rows.Count, 1).End(xlUp).Row .Range("A1").AutoFilter 1, "*" & TextBox1.Value & "*" If .Cells(Rows.Count, "A").End(xlUp).Row > 1 Then Set rng = .Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible) Else Me.ListBox1.Clear Exit Sub End If End With Me.ListBox1.Clear With Me.ListBox1 For Each r In rng .AddItem r.Value .List(.ListCount - 1, 1) = r.Offset(0, 1).Value Next r End With End Sub Private Sub UserForm_Initialize() Dim LastRow As Integer Dim rng As Range, r As Range With Worksheets("Sheet1") If .AutoFilterMode <> True Then .Range("A1").AutoFilter End If LastRow = .Cells(Rows.Count, 1).End(xlUp).Row Set rng = .Range("A2:A" & LastRow) End With With Me.ListBox1 .ColumnCount = 1 For Each r In rng .AddItem r.Value .List(.ListCount - 1, 1) = r.Offset(0, 1).Value Next r End With ListBox1.ListIndex = 0 End Sub とりあえず検索はできるのですが、使用されていない文字や記号を入力したあとにバックスペースキーで入力した文字や記号を削除するとリストボックスの内容が意図した内容で表示されません。 どこを修正したらいいでしょうか。

  • エクセルのマクロの質問です。

    エクセルのマクロの質問です。 こんにちわ。エクセルのマクロを始めて間もないものです。 下記ようなマクロを組みましたが「Windows("B.xls").Activate」(※の部分)でとまってしまいます。 なぜかもわからず困っています。 Workbooks.Open Filename:="B.xls" For i = 1 To 1000 Step 1 Range(Cells(i, 1), Cells(i, 5)).Select Selection.Copy Windows("A.xls").Activate Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Select ActiveSheet.Paste ※ Windows("B.xls").Activate Next i 一応、動作としては Bのマクロを開く→ループ始点（1000回繰り返す） 一回目⇒A1～B5をコピー→Aのエクセルを開く→A列のセル１行目に貼り付ける→Bのエクセルを開く 二回目⇒A2～B5をコピー→Aのエクセルを開く→A列のセル２行目に貼り付ける→Bのエクセルを開く . . . ループ終点 こんな感じで作成しましたが、どうしても上手く動かないで困っています。 無駄な動作が多いかもしれませんが、ぜひアドバイスをお願いします。 また、もっと簡単な動作ができるのであればそちらもお願いします。

  • エクセルVBAプログラム質問 リストボックス応用

    エクセルVBAプログラムについて質問です。 リストボックスから結果をリストボックスに表示させる リストボックスを応用した内容です。 (1)今回追加したいのは、チェックボックスにチェックすることで、 期限が今月中に切れるもののみをリストボックスに表示させたいです。 (2)期限更新ボタンを押したら、3カ月プラスして延長させたいです。 期限更新したら、リストボックスの中身も更新したいです。 例(1)：今日の日付 2018/9/23だとしたら、期限切れる（9月分すべて）を表示させたい。 例(2)：期限（変更前）『2018/9/23』から期限（変更後）『2018/12/23』に変更 下記のプログラムで追加していきたいです。 Dim myData Private Sub UserForm_Initialize() Dim Dic, Keys, buf As String, i As Long Me.ComboBox1.Style = fmStyleDropDownList Me.ListBox1.ColumnCount = 4 Me.ListBox1.ListStyle = fmListStyleOption Me.ListBox1.MultiSelect = fmMultiSelectMulti Me.CommandButton1.Caption = "印刷" Me.CommandButton1.Enabled = False With Worksheets("DATA") myData = .Range("A1:E" & .Cells(.Rows.Count, 1).End(xlUp).Row) End With Set Dic = CreateObject("Scripting.Dictionary") On Error Resume Next For i = 2 To UBound(myData, 1) buf = myData(i, 1) Dic.Add buf, buf Next i Keys = Dic.Keys For i = 0 To Dic.Count - 1 Me.ComboBox1.AddItem Keys(i) Next i Set Dic = Nothing End Sub Private Sub ComboBox1_Change() Dim i As Long, j As Integer With Me.ListBox1 .Clear For i = 2 To UBound(myData, 1) If Me.ComboBox1.Value = myData(i, 1) Then .AddItem "" For j = 2 To 5 .List(.ListCount - 1, j - 2) = myData(i, j) Next j End If Next i End With End Sub Private Sub ListBox1_Change() Dim i As Long, cnt As Long With Me.ListBox1 For i = 0 To .ListCount - 1 If .Selected(i) Then cnt = cnt + 1 End If Next i End With Me.CommandButton1.Enabled = (1 <= cnt And cnt <= 2) End Sub Private Sub CommandButton1_Click() Dim ws As Worksheet, i As Long, j As Integer, cnt As Byte Set ws = Worksheets("印刷") ws.PageSetup.PrintArea = "$I$2:$P$5" ws.Range("J2:L5,N2:P5").ClearContents With Me.ListBox1 For i = 0 To .ListCount - 1 If .Selected(i) Then ws.Range("J2").Offset(0, cnt).Value = Me.ComboBox1.Value For j = 0 To 2 ws.Range("J5").Offset(j * -1, cnt).Value = .List(i, j) Next j cnt = cnt + 2 End If Next i End With Unload Me ws.PrintPreview End Sub

  • エクセルマクロ・Cells.Find のエラー

    　 VBA初心者です。 ファイルA の C列 に入力されているデータが ファイルB に含まれているかどうか検索するマクロを Cells.Find を使って作ろうとしています。 データがファイルBに存在する場合は問題ありませんが存在 していない場合エラーが出て止まってしまいます。 ヘルプを見ると「セルが見つからなかった場合は、Nothingを返します」 と書かれていますが、どうもNothingとは返ってきません。 このエラーを回避する方法を教えてください。 例えばこんなマクロを組みました。 　For tate = 0 To 19 　　　Windows("ファイルA.xls").Activate 　　　Range("C1").Offset(tate, 0).Select 　　　データ = Range("C1").Offset(tate, 0) 　　　Windows("ファイルB.xls").Activate 　　　Cells.Find(データ, MatchCase:=False).Activate 　Next tate 例えば最後の2行を 　　　結果 = Cells.Find(What:=ISISDate, MatchCase:=False).Activate 　　　　　MsgBox (結果) 　Next tate とするとデータが含まれている場合は「True」と返ってきますが、 含まれていない場合は MsgBox が表示される前にエラーとなってしまいます。 とりあえずこのエラーを回避する方法をご存知でしたらお教えください。 　

  • vba マクロの組み立て不能

    毎度お世話になります。 Sub 呼び込み() ChDir "C:\08-C\9\1k-1\m\" Dim c1 As Variant Dim ran1 As Range Set ran1 = Range("ad16: ad40") '<----- Windows("SW.xls").ActiveSheet 記録前の削除 ran1.Delete Shift:=xlShiftToLeft For i = 1 To 10 '<----- 実際には10から20です。 Workbooks.Open Filename:=ThisWorkbook.ActiveSheet.Cells(i + 10, "A") & ".xls", UpdateLinks:=3 Windows("SW.xls").Activate With Windows("SW.xls").ActiveSheet c1 = Cells(i + 10, "A") .Cells(i + 15, 30).Formula = "Windows" & "(" & Chr$(34) & c1 & ".xls" & Chr$(34) & ").Activate" ' 出来上がり例 Windows("出来高.xls").Activate　とかWindows("1334.xls").Activate　　 End With Next i End Sub 'Sub 呼び込み() した後に時間をおいて保存に移りたいのですが　Range("ad16")よりの書き込みにを '利用して保存をしたいのです。　例＞　Windows("出来高移動平均.xls").Activate Sub 保存() Range("AD17").Select Application.CutCopyMode = False Selection.Copy ' 実際には此処に挿入したいがマクロ組み立て不能です。 Windows("出来高.xls").Activate '<----- 実際には此処に挿入したいがマクロ組み立て不能です。 ActiveWorkbook.Save: ActiveWindow.Close End Sub

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する