dポイントプレゼントキャンペーン実施中!

VBA初心者です。
入門書を読み、コンボボックスを用いる(一つの条件検索)で請求書ツール作成までできたのですが、画像のようにユーザーフォームに複数選択リストを設けると現在のコードですと、エラーになってしまいます。
つきましては、リストボックスで条件を複数選択可能にして、該当データを転記するといったことを行いたいです。大変恐縮ですが、コードをご教示お願い致します。

↓参考に、現状のコードを下記致します。

(ユーザーフォームのコード)

Private Sub btnExit_Click()
Unload Me
End Sub

Private Sub UserForm_Initialize()
Dim ListRange As Range
Dim temp As Range
Dim vYear As Long
Dim i As Long

With Worksheets("取引先一覧").Range("A1").CurrentRegion
Set ListRange = .Resize(.Rows.Count - 1).Offset(1)
End With

For Each temp In ListRange
cmbcompany.AddItem temp.Value
Next

vYear = Year(Date)
cmbYear.AddItem vYear - 1
cmbYear.AddItem vYear
cmbYear.AddItem vYear + 1
cmbYear.Value = vYear

For i = 1 To 12
cmbMonth.AddItem i
Next
End Sub

Private Sub btnMakeBill_Click()
MakeBill cmbcompany.Text, cmbYear.Text, cmbMonth.Text
End Sub

(標準モジュールのコード)

Option Explicit

Sub Main()
frmMakeBill.Show
End Sub

Sub MakeBill(ByVal vCompany As String, ByVal vYear As Long, ByVal vMonth As Long)
Dim TargetSheet As Worksheet
Dim vDate As Date
Dim DataRange As Range
Dim TargetRange As Range
Dim BillBook As Workbook
Dim i As Long, vRow As Long
Dim vInfo(1 To 2) As String

On Error Resume Next
Worksheets("請求書Template").Copy After:=Worksheets(Worksheets.Count)

If Err.Number <> 0 Then
MsgBox "「請求書Template」ワークシートが見つかりません。確認下ください"
Exit Sub
End If
On Error GoTo 0

On Error GoTo ErrHdl
Set TargetSheet = Worksheets(Worksheets.Count)
Set TargetRange = TargetSheet.Range("A18")

i = 1
vRow = 1
With Worksheets("受注データ").Range("A9")
Do Until .Cells(i, 1).Value = ""
vDate = .Cells(i, 1).Value
If .Cells(i, 2).Value = vCompany _
And Year(vDate) = vYear And Month(vDate) = vMonth Then
TargetRange.Cells(vRow, 1).Value = .Cells(i, 1).Value '「日付」列
TargetRange.Cells(vRow, 2).Value = .Cells(i, 3).Value '「商品コード」列
TargetRange.Cells(vRow, 3).Value = .Cells(i, 4).Value '「商品名」列
TargetRange.Cells(vRow, 4).Value = .Cells(i, 5).Value '「数量」列
TargetRange.Cells(vRow, 5).Value = .Cells(i, 6).Value '「単価」列
TargetRange.Cells(vRow, 6).Value = .Cells(i, 7).Value '「金額」列
vRow = vRow + 1
End If
i = i + 1
Loop
TargetSheet.Range("F28").Formula = "=SUM(F18:F27)" '「小計」
TargetSheet.Range("F29").Formula = "=F28 * 0.08" '「消費税額」
TargetSheet.Range("F30").Formula = "=F28 + F29" '「合計金額」
TargetSheet.Range("B6").Formula = "F30" '請求額

vInfo(1) = Date
vInfo(2) = vCompany
TargetSheet.Range("F2").Value = vInfo(1) '「請求日」
TargetSheet.Range("A6").Value = vInfo(2) '「請求先」
End With

Set BillBook = Workbooks.Add
TargetSheet.Cells.Copy BillBook.Worksheets(1).Range("A1")
Application.DisplayAlerts = False
TargetSheet.Delete
Application.DisplayAlerts = True

Exit Sub

ErrHdl:
MsgBox "エラーが発生しました。処理を終了します"
End Sub

「VBA リストボックス(複数条件)で検索」の質問画像

A 回答 (2件)

こんにちは


コードを拝見すると、?がありますが、
先ずは、
コンボボックスからリストボックスに変更していますよね。
リストボックスで条件を複数選択可能にするの
プロパティであらかじめ設定するか、
Initializeで
cmbcompany.MultiSelect = fmMultiSelectMulti
などとすれば良いかと。。 ここは、大丈夫そう?。

あと 肝心の
MakeBill cmbcompany.Text, cmbYear.Text, cmbMonth.Text
すべて Stringに対し
Sub MakeBill(ByVal vCompany As String, ByVal vYear As Long, ByVal vMonth As Long)
String, Long, Long、、、エラーだと思うけど

実際に試すの大変そうなので、検証していませんが
cmbcompany オブジェクトが ListBoxであるとして
選択されている値をMakeBillに投げれば良いのでは無いかと
多分それが一番簡単かな、、

Private Sub btnMakeBill_Click()
MakeBill cmbcompany.Text, cmbYear.Text, cmbMonth.Text
End Sub


Private Sub btnMakeBill_Click()
Dim i As Integer
With cmbcompany
For i = 0 To .ListCount - 1
If .Selected(i) = True Then
MakeBill .List(i), cmbYear.Text, cmbMonth.Text
End If
Next i
End With
End Sub
型を確認する事。
内容をよく見ていないので参考まで
    • good
    • 1

まず。



>On Error GoTo ErrHdl

をコメントアウトにして『どこでエラーが出ているのか?』を把握した上で質問された方が的を絞った内容になると思いますよ。
個人的にはエラーが発生しないコード作成が好きですし、初級レベルなジジィは昔諸先輩方にそう教わりました。

☆彡複数選択可能なリストボックス
http://officetanaka.net/excel/vba/tips/tips144.htm
選択されている項目を調べる

によって、その値が選択されているか否かの条件式で選択されている場合だけ次に進むようにすれば宜しいのでは?
ここまで書ける方なら実際のコードはリンク先を参考にちょっと修正するくらいかなと思われます。

『ExcelVBA リストボックス 複数選択』でググりました。
    • good
    • 1

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています


このQ&Aを見た人がよく見るQ&A