Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


11705 / 76734 ←次へ | 前へ→

【70561】ユーザーフォームのチェックボックスの複数選択について
質問  atsjack  - 11/11/30(水) 23:59 -

引用なし
パスワード
   はじめまして。
ExcelVBAを勉強し始めて間もない初心者ですが、質問させてください。
初心者故、お見苦しい部分があるかもしれませんが、ご容赦お願いいたします。

早速ですが、掲題の件について質問です。

"productlist"シート(商品の情報一覧)から選択した商品のみを
"Base"シート(発注書)に抽出、表示する処理をVBAにて作成したいと考えております。

手順としては、
1.ユーザーフォーム+チェックボックスでアイテムを複数選択
2.複数の該当商品情報をコピー

現在、2.の"複数"という部分で躓いております。
下記コードを作成いたしましたが、複数チェックしても一番最後の商品のみコピーされるだけの状態です。

チェックした商品すべてをコピーするにはどのような修正を行ったらよいでしょうか。

ご教授の程、宜しくお願いいたします。


-----以下コード-----


Function LastRow(st As Worksheet, C As Long) As Variant

'--最終行を調べる関数

  LastRow = st.Cells(st.Rows.Count, C).End(xlUp).Row

End Function

Sub publishbuttun_Click()

  Dim i As Long
  Dim itemchk(1 To 58) As Boolean
  Dim item(1 To 58) As Range
  Dim 最終行 As Long
  Dim 貼付行 As Long
  Dim ash As Worksheet
  Dim plsh As Worksheet
    
  Set ash = ThisWorkbook.Worksheets("Base")
  Set plsh = ThisWorkbook.Worksheets("productlist")
  最終行 = LastRow(ash, 2)
  貼付行 = 最終行 + 1
  
  For i = 1 To 58

'--チェックボックスの値を調べる--

    itemchk(i) = Me.Controls("CheckBox" & i).Value
    
'--プロダクトリストを参照--
    
    With plsh
    
      Set item(i) = .Range(.Cells(i + 6, 2), .Cells(i + 6, 8))
   
    End With

'--チェックボックスがTrueの商品の情報をコピーする--

    If itemchk(i) = True Then
      
      item(i).Copy Destination:=ash.Range(ash.Cells(貼付行, 2), ash.Cells(貼付行, 8)) 
    
    End If
  
  Next i

'--閉じる--

  Unload Me

End Sub

Sub UserForm_Initialize()

For i = 1 To 58
  
'--チェックボックスのキャプションを変更
  
  Me.Controls("CheckBox" & i).Caption = Worksheets("productlist").Range("C" & i + 6)
  
Next i

End Sub
5 hits

【70561】ユーザーフォームのチェックボックスの複数選択について atsjack 11/11/30(水) 23:59 質問
【70562】Re:ユーザーフォームのチェックボックスの... みそじのおじさん 11/12/1(木) 0:36 発言
【70563】Re:ユーザーフォームのチェックボックスの... とおりすぎ 11/12/1(木) 0:45 回答
【70564】Re:ユーザーフォームのチェックボックスの... とおりすぎ 11/12/1(木) 0:47 発言
【70565】Re:ユーザーフォームのチェックボックスの... atsjack 11/12/1(木) 1:10 お礼

11705 / 76734 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free