[[20211027154204]]　『リストボックスから追加する列を選択し書き込む』（いち）　ページの最後に飛ぶ

『リストボックスから追加する列を選択し書き込む』（いち）

新しい品目を分類ごとに分ける作業をしています。

O列に作成された新しい品目をユーザーフォームにて確認し、その中で選択された品目をＡ～Ｎ列にある分類のどこに挿入するかを一つずつ選んで
選ばれた列の最終行に追加をするマクロを作成したいです。
ユーザーフォームを作成するのが初めてで、下記のコードでＱ列に全て書き出すことはできたのですが、ここからどうしたら一つ一つどの分類に分けれるのかが分かりません。

ご教授頂けないでしょうか。

Private Sub UserForm_Initialize()
With ListBox1

        .ColumnCount = 1
        .ColumnWidths = "50"
        .RowSource = "品目!O2:O" & Worksheets("品目").Cells(Rows.Count, 15).End(xlUp).Row
        .ColumnHeads = True
        .MultiSelect = fmMultiSelectMulti
        .ListStyle = fmListStyleOption
    End With
End Sub

Private Sub CommandButton1_Click()
Dim i As Integer, j As Integer

    j = 1

    With ListBox1
        For i = 0 To ListBox1.ListCount - 1
            If ListBox1.Selected(i) Then
                Cells(j, 17).Value = ListBox1.List(i)
                j = j + 1
                ListBox1.Selected(i) = False
            End If
        Next i
    End With

End Sub

＜使用 Excel：Excel2010、使用 OS：Windows10 ＞

 ＞その中で選択された品目をＡ～Ｎ列にある分類のどこに挿入するかを一つずつ選んで

 ・・で、選択された品目がどの分類に入るのか、何を以て判断するんですか？

（半平太） 2021/10/27(水) 16:17

アクティブセルの列で転送先を選ぶ例です。

 Private Sub CommandButton1_Click()
    Dim iColumn As Long
    Dim i As Integer, j As Integer
    iColumn = ActiveCell.Column
    j = Cells(Rows.Count, iColumn).End(xlUp).Row + 1
    With ListBox1
        For i = 0 To ListBox1.ListCount - 1
            If ListBox1.Selected(i) Then
                Cells(j, iColumn).Value = ListBox1.List(i)
                j = j + 1
                ListBox1.Selected(i) = False
            End If
        Next i
    End With
 End Sub

（きまぐれおじさん） 2021/10/27(水) 16:19

半平田　様　ご回答ありがとうございます。
どの分類に入るかは品目に入るアルファベットを基にしているのですが、規則性がないので実際に見て判断をします。自動で分けるのは難しいです。

きまぐれおじさん　様　ご回答ありがとうございます。

例えばＯ列にある品目の中から2つ選択し、そのどちらもアクティブセルの列に書き出すのではなく、一つはＡ列に、もう一つはＤ列に等、その都度挿入する列を変える場合を教えて頂けないでしょうか。
（いち） 2021/10/27(水) 16:39

＞自動で分けるのは難しい

その場合自動化することも難しいです。

（きまぐれおじさん） 2021/10/27(水) 16:41

その都度挿入する列を変える場合

ユーザーフォームをモードレスで表示

 UserForm1.Show vbModeless

Private Sub CommandButton1_Click()

    Dim i As Long, j As Long, myCell As Range
    With ListBox1
        For i = 0 To ListBox1.ListCount - 1
            If ListBox1.Selected(i) Then
                Set myCell = Application.InputBox(prompt:=ListBox1.List(i) & " を転記する列を選択してください。", Type:=8)
                j = Cells(Rows.Count, myCell.Column).End(xlUp).Row + 1
                Cells(j, myCell.Column).Value = ListBox1.List(i)
                ListBox1.Selected(i) = False
            End If
        Next i
    End With
End Sub

（ピンク） 2021/10/27(水) 16:51

きまぐれおじさん　様

自動で分けるところは手動でその他は自動にしたくご質問させて頂きました。

ピンク　様　ご回答ありがとうございます。

インプットボックスを活用し希望通りの動きを確認できました。
モードレスについて教えて頂きたいのですが、　vbModeless　を追加すると
Private Sub CommandButton1_Click()のマクロが実行されません。
UserForm1のマクロに何かしらのコードを追加しなければいけないのでしょうか？

（いち） 2021/10/28(木) 09:58

 >vbModeless　を追加すると

 すみません、vbModelessは必要なかったです。
（ピンク） 2021/10/28(木) 10:45

ピンク　様

ありがとうございます。
大変助かりました。

（いち） 2021/10/28(木) 11:06

ピンク　様

すみません、またつまづいてしまったのですが、インプットボックスにより品目を追加し、その後Ｏ列の品目を消すことはできないのでしょうか？
　Cells(j, myCell.Column).Value = ListBox1.List(i)
　Cells(〇,15).Delete

と追加してみました。〇の部分を色々試してみたのですが、上手くいかず・・・

ご教授頂けないでしょうか。

（いち） 2021/10/28(木) 16:24

 >その後Ｏ列の品目を消すことはできないのでしょうか？

 各列に転記後、一括で削除しました。

 Private Sub CommandButton1_Click()
    Dim i As Long, j As Long, myCell As Range
    Dim v() As String, k As Long, myStr As Variant
    With ListBox1
        For i = 0 To ListBox1.ListCount - 1
            If ListBox1.Selected(i) Then
                Set myCell = Application.InputBox(prompt:=ListBox1.List(i) & " を転記する列を選択してください。", Type:=8)
                j = Cells(Rows.Count, myCell.Column).End(xlUp).Row + 1
                Cells(j, myCell.Column).Value = ListBox1.List(i)
                ReDim Preserve v(0 To k)
                v(k) = ListBox1.List(i)
                k = k + 1
                ListBox1.Selected(i) = False
            End If
        Next i
    End With
    Dim myR As Variant
    With Worksheets("品目")
        For Each myStr In v
            myR = Application.Match(myStr, .Columns(15), 0)
            .Cells(myR, 15).Delete Shift:=xlUp
        Next
   End With
End Sub

（ピンク） 2021/10/28(木) 19:13

 Private Sub CommandButton1_Click()
    Dim i As Long, j As Long, myCell As Range
    Dim v() As String, k As Long, myStr As Variant
    With Me.ListBox1
        For i = 0 To .ListCount - 1
            If .Selected(i) Then
                Set myCell = Application.InputBox(prompt:="【" & .List(i) & "】" & _
                        vbCrLf & "を転記する列を選択してください。", Type:=8)
                j = Cells(Rows.Count, myCell.Column).End(xlUp).Row + 1
                Cells(j, myCell.Column).Value = .List(i)
                ReDim Preserve v(0 To k)
                v(k) = .List(i)
                k = k + 1
                .Selected(i) = False
            End If
        Next i
    End With
    Dim myR As Variant
    With Worksheets("品目")
        For Each myStr In v
            myR = Application.Match(myStr, .Columns(15), 0)
            .Cells(myR, 15).Delete Shift:=xlUp
        Next
        Me.ListBox1.RowSource = .Name & "!O2:O" & .Cells(Rows.Count, 15).End(xlUp).Row
    End With
 End Sub

（ピンク） 2021/10/28(木) 22:59

ピンク　様

ありがとうございます！
とても作業効率があがりました。

まだ内容を詳しく見れていませんが、取り急ぎお礼申し上げます。
これからひとつひとつ理解し他にも活用していきたいと思います。
ありがとうございました。

（いち） 2021/10/29(金) 11:24

コメント返信：

[ 一覧(最新更新順) ]

[[20211027154204]] 『リストボックスから追加する列を選択し書き込む』（いち） ページの最後に飛ぶ

[[20211027154204]]　『リストボックスから追加する列を選択し書き込む』（いち）　ページの最後に飛ぶ