How about setting up a worksheet that looks like a little form:
First, some house keeping.
I put the "form" stuff on Sheet1.
I put the clothing list on sheet2 in A1:A???.
1 shirt
2 shirts
3 shirts
1 belt
2 belts
1 pair of pants
2 pair of pants
The output will go onto sheet3.
On sheet1, I put the name in A1 and more info in B1, C1.
Then I used the control toolbox toolbar (not the Forms toolbar) to add two
listboxes (listbox1 and listbox2).
Then I added 6 commandbuttons right between the two listboxes.
The commandbuttons are named:
BTN_moveAllLeft
BTN_moveAllRight
BTN_MoveSelectedLeft
BTN_MoveSelectedRight
btn_resetValues
btn_writetosheet
(I rightclicked on each to change the name and the caption.)
Then I rightclicked on the sheet1 tab, selected view code and pasted this in:
Option Explicit
Private Sub BTN_moveAllLeft_Click()
Dim iCtr As Long
For iCtr = 0 To Me.ListBox2.ListCount - 1
Me.ListBox1.AddItem Me.ListBox2.List(iCtr)
Next iCtr
Me.ListBox2.Clear
End Sub
Private Sub BTN_moveAllRight_Click()
Dim iCtr As Long
For iCtr = 0 To Me.ListBox1.ListCount - 1
Me.ListBox2.AddItem Me.ListBox1.List(iCtr)
Next iCtr
Me.ListBox1.Clear
End Sub
Private Sub BTN_MoveSelectedLeft_Click()
Dim iCtr As Long
For iCtr = 0 To Me.ListBox2.ListCount - 1
If Me.ListBox2.Selected(iCtr) = True Then
Me.ListBox1.AddItem Me.ListBox2.List(iCtr)
End If
Next iCtr
For iCtr = Me.ListBox2.ListCount - 1 To 0 Step -1
If Me.ListBox2.Selected(iCtr) = True Then
Me.ListBox2.RemoveItem iCtr
End If
Next iCtr
End Sub
Private Sub BTN_MoveSelectedRight_Click()
Dim iCtr As Long
For iCtr = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(iCtr) = True Then
Me.ListBox2.AddItem Me.ListBox1.List(iCtr)
End If
Next iCtr
For iCtr = Me.ListBox1.ListCount - 1 To 0 Step -1
If Me.ListBox1.Selected(iCtr) = True Then
Me.ListBox1.RemoveItem iCtr
End If
Next iCtr
End Sub
Private Sub btn_resetValues_Click()
Dim myCell As Range
Dim myRng As Range
With Worksheets("sheet2")
Set myRng = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
End With
Me.ListBox1.Clear
Me.ListBox2.Clear
With Me.ListBox1
.LinkedCell = ""
.ListFillRange = ""
For Each myCell In myRng.Cells
If Trim(myCell) <> "" Then
.AddItem myCell.Value
End If
Next myCell
End With
Me.ListBox1.MultiSelect = fmMultiSelectMulti
Me.ListBox2.MultiSelect = fmMultiSelectMulti
End Sub
Private Sub btn_writetosheet_Click()
Dim iCtr As Long
Dim DestCell As Range
Dim resp As Long
Dim NameCell As Range
Set NameCell = Me.Range("a1")
If Trim(NameCell.Value) = "" Then
MsgBox "Don't forget the name!"
Exit Sub
End If
If Me.ListBox2.ListCount = 0 Then
MsgBox "no clothes selected!"
Exit Sub
End If
resp = MsgBox(prompt:="are you ready to write values for: " _
& NameCell.Value, Buttons:=vbYesNo)
If resp = vbNo Then
Exit Sub
End If
With Worksheets("sheet3")
Set DestCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
For iCtr = 0 To Me.ListBox2.ListCount - 1
DestCell.Offset(iCtr, 0).Value = NameCell.Value
DestCell.Offset(iCtr, 1).Value = NameCell.Offset(0, 1).Value
DestCell.Offset(iCtr, 2).Value = NameCell.Offset(0, 2).Value
DestCell.Offset(iCtr, 3).Value = Me.ListBox1.List(iCtr)
Next iCtr
End With
Call btn_resetValues_Click
End Sub
If you want more "header" stuff (a1:z1), then you can play with this portion:
DestCell.Offset(iCtr, 0).Value = NameCell.Value
DestCell.Offset(iCtr, 1).Value = NameCell.Offset(0, 1).Value
DestCell.Offset(iCtr, 2).Value = NameCell.Offset(0, 2).Value
DestCell.Offset(iCtr, 3).Value = Me.ListBox1.List(iCtr)
