VBA Code for multi select - listbox as inputbox

GeneBF

New Member
Joined
Jun 28, 2022
Messages
34
Office Version
  1. 365
Platform
  1. Windows
I would like to create a command button code that will pop-up a list box listing all the sheets present in the workbook.
For each selected sheet in the list box it will copy a specific column on selected sheet in listbox, and paste to a new sheet to a diffrent column

Example
I have Sheets - 'Block A', 'Block B', 'Block C', 'Block D'
Press button - Listbox pop-up including all the present sheet in the book
Select in list box - 'Block A', 'Block B', 'Block D' only
Column to copy for each - C:C
New Sheet to be generated - 'Building A'
Now Each Column C:C copied will be pasted to Sheet 'Building A' on different column with interval of 2 columns each
so it will look like
Building A Sheet's:
Column A - contains Column C:C of Block A
Column D - contains Column C:C of Block B
Column G - contains Column C:C of Block D

...and so on depending on number of sheets ticked in the list box.
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
Put this code in a standard module and assign the Main_List_Sheets macro to your command button. It actually creates a list box on the active sheet and below it a button with the Copy_Column_From_Selected_Sheets routine as its OnAction macro which copies column C:C from the selected sheet(s) to the newly added 'Building A' sheet.

VBA Code:
Option Explicit

Public Sub Main_List_Sheets()

    Dim sheetsListBox As ListBox
    Dim copySheetsButton As Button
    Dim ws As Worksheet
    
    With ActiveSheet
        Set sheetsListBox = .ListBoxes.Add(.Range("K2").Left, .Range("K2").Top, 160, 84)
        Set copySheetsButton = .Buttons.Add(sheetsListBox.Left, sheetsListBox.Top + sheetsListBox.Height + 5, 140, 60)
    End With
    
    With sheetsListBox
        .Name = "List Sheets"
        .MultiSelect = xlSimple
        For Each ws In ActiveWorkbook.Worksheets
            .AddItem ws.Name
        Next
    End With
    
    With copySheetsButton
        .Name = "Copy Column"
        .Caption = "Copy column C:C of selected sheet(s) to new sheet"
        .OnAction = "Copy_Column_From_Selected_Sheets"
    End With
        
End Sub


Public Sub Copy_Column_From_Selected_Sheets()

    Dim currentSheet As Worksheet
    Dim sheetsListBox As ListBox
    Dim copySheetsButton As Button
    Dim i As Long, numSelectedSheets As Long, colNumber As Long
    Dim newWs As Worksheet
    
    Set currentSheet = ActiveSheet
    Set sheetsListBox = ActiveSheet.ListBoxes("List Sheets")
    Set copySheetsButton = ActiveSheet.Buttons("Copy Column")
    
    With sheetsListBox
        numSelectedSheets = 0
        For i = 1 To .ListCount
            If .Selected(i) Then numSelectedSheets = numSelectedSheets + 1
        Next
        If numSelectedSheets > 0 Then
            Set newWs = ActiveWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count))
            newWs.Name = "Building A"
            colNumber = 1
            For i = 1 To .ListCount
                If .Selected(i) Then
                    ActiveWorkbook.Worksheets(.List(i)).Columns("C:C").Copy newWs.Cells(1, colNumber)
                    colNumber = colNumber + 3
                End If
            Next
        Else
            MsgBox "No sheets selected", vbInformation
        End If
    End With
    
    sheetsListBox.Delete
    copySheetsButton.Delete

    currentSheet.Select
    
End Sub
 
Upvote 0
Solution
Hi thanks this is working as Intended though I'm not that familiar to all the codes used as Im new in VBA too,
what if I want to change the paste to pastespecial. as values , as formats, as validation (cause i have some situation for those too)
I also dont know why, but the listsheet and button just sits there after clicking even though theres a .delete code for both of it as you can see it just keeps on piling up
1657765974285.png
Thanks!

another thing is it stopped working when I edit the code to have an input for sheet name and moved the starting column and interval

VBA Code:
Public Sub Copy_Column_From_Selected_Sheets()

    Dim currentSheet As Worksheet
    Dim sheetsListBox As ListBox
    Dim copySheetsButton As Button
    Dim i As Long, numSelectedSheets As Long, colNumber As Long
    Dim newWs As Worksheet
    Dim newWsName As String
    
    newWsName = InputBox("Input Building Name")
    
    Set currentSheet = ActiveSheet
    Set sheetsListBox = ActiveSheet.ListBoxes("List Sheets")
    Set copySheetsButton = ActiveSheet.Buttons("Copy Column")
    
    With sheetsListBox
        numSelectedSheets = 0
        For i = 1 To .ListCount
            If .Selected(i) Then numSelectedSheets = numSelectedSheets + 1
        Next
        If numSelectedSheets > 0 Then
            Set newWs = ActiveWorkbook.Worksheets.Add(Before:=Worksheets(1))
            newWs.Name = newWsName
            colNumber = 4
            For i = 1 To .ListCount
                If .Selected(i) Then
                    ActiveWorkbook.Worksheets(.List(i)).Columns("F:F").Copy newWs.Cells(1, colNumber)
                    colNumber = colNumber + 2
                End If
            Next
        Else
            MsgBox "No sheets selected", vbInformation
        End If
    End With
    
    sheetsListBox.Delete
    copySheetsButton.Delete
    
     

    
End Sub
Put this code in a standard module and assign the Main_List_Sheets macro to your command button. It actually creates a list box on the active sheet and below it a button with the Copy_Column_From_Selected_Sheets routine as its OnAction macro which copies column C:C from the selected sheet(s) to the newly added 'Building A' sheet.
 
Upvote 0
ahh, figured out the error on listsheet and commandbutton not being deleted. when the main button is clicked multiple times it generates both listbox and button for each click. is there anyway to prevent this or just clear the previous box and button when the button is clicked again?
 
Upvote 0
what if I want to change the paste to pastespecial. as values , as formats, as validation (cause i have some situation for those too)
I also dont know why, but the listsheet and button just sits there after clicking even though theres a .delete code for both of it as you can see it just keeps on piling up
This fixes the duplicating controls problem:
VBA Code:
Public Sub Main_List_Sheets()

    Dim sheetsListBox As ListBox
    Dim copySheetsButton As Button
    Dim ws As Worksheet
       
    With ActiveSheet
        Set sheetsListBox = Nothing
        On Error Resume Next
        Set sheetsListBox = .ListBoxes("List Sheets")
        On Error GoTo 0
        If sheetsListBox Is Nothing Then Set sheetsListBox = .ListBoxes.Add(.Range("K2").Left, .Range("K2").Top, 160, 84)
        
        Set copySheetsButton = Nothing
        On Error Resume Next
        Set copySheetsButton = .Buttons("Copy Column")
        On Error GoTo 0
        If copySheetsButton Is Nothing Then Set copySheetsButton = .Buttons.Add(sheetsListBox.Left, sheetsListBox.Top + sheetsListBox.Height + 5, 140, 60)
    End With
    
    With sheetsListBox
        .Name = "List Sheets"
        .RemoveAllItems
        .MultiSelect = xlSimple
        For Each ws In ActiveWorkbook.Worksheets
            .AddItem ws.Name
        Next
    End With
    
    With copySheetsButton
        .Name = "Copy Column"
        .Caption = "Copy column C:C of selected sheet(s) to new sheet"
        .OnAction = "Copy_Column_From_Selected_Sheets"
    End With
        
End Sub

For Copy and Paste Special, record a macro of your actions and the generated macro can be incorporated into the code, for example:
VBA Code:
                    ActiveWorkbook.Worksheets(.List(i)).Columns("C:C").Copy
                    newWs.Cells(1, colNumber).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    newWs.Cells(1, colNumber).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    newWs.Cells(1, colNumber).PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    Application.CutCopyMode = False
 
Upvote 0
This fixes the duplicating controls problem:
VBA Code:
Public Sub Main_List_Sheets()

    Dim sheetsListBox As ListBox
    Dim copySheetsButton As Button
    Dim ws As Worksheet
      
    With ActiveSheet
        Set sheetsListBox = Nothing
        On Error Resume Next
        Set sheetsListBox = .ListBoxes("List Sheets")
        On Error GoTo 0
        If sheetsListBox Is Nothing Then Set sheetsListBox = .ListBoxes.Add(.Range("K2").Left, .Range("K2").Top, 160, 84)
       
        Set copySheetsButton = Nothing
        On Error Resume Next
        Set copySheetsButton = .Buttons("Copy Column")
        On Error GoTo 0
        If copySheetsButton Is Nothing Then Set copySheetsButton = .Buttons.Add(sheetsListBox.Left, sheetsListBox.Top + sheetsListBox.Height + 5, 140, 60)
    End With
   
    With sheetsListBox
        .Name = "List Sheets"
        .RemoveAllItems
        .MultiSelect = xlSimple
        For Each ws In ActiveWorkbook.Worksheets
            .AddItem ws.Name
        Next
    End With
   
    With copySheetsButton
        .Name = "Copy Column"
        .Caption = "Copy column C:C of selected sheet(s) to new sheet"
        .OnAction = "Copy_Column_From_Selected_Sheets"
    End With
       
End Sub

For Copy and Paste Special, record a macro of your actions and the generated macro can be incorporated into the code, for example:
VBA Code:
                    ActiveWorkbook.Worksheets(.List(i)).Columns("C:C").Copy
                    newWs.Cells(1, colNumber).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    newWs.Cells(1, colNumber).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    newWs.Cells(1, colNumber).PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    Application.CutCopyMode = False
Hi it works great now! i can work around this one now, thanks !
One Last thing is there a way that when user click away instead of proceeding with the button the listbox and commandbutton disappears too?
 
Upvote 0
One Last thing is there a way that when user click away instead of proceeding with the button the listbox and commandbutton disappears too?
Put this code in the sheet module of the sheet containing the listbox and button:
VBA Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim sheetsListBox As ListBox
    Dim copySheetsButton As Button
    
    Set sheetsListBox = Nothing
    On Error Resume Next
    Set sheetsListBox = ActiveSheet.ListBoxes("List Sheets")
    On Error GoTo 0
    If Not sheetsListBox Is Nothing Then sheetsListBox.Delete
    
    Set copySheetsButton = Nothing
    On Error Resume Next
    Set copySheetsButton = ActiveSheet.Buttons("Copy Column")
    On Error GoTo 0
    If Not copySheetsButton Is Nothing Then copySheetsButton.Delete
    
End Sub
 
Upvote 0
Put this code in the sheet module of the sheet containing the listbox and button:
VBA Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim sheetsListBox As ListBox
    Dim copySheetsButton As Button
   
    Set sheetsListBox = Nothing
    On Error Resume Next
    Set sheetsListBox = ActiveSheet.ListBoxes("List Sheets")
    On Error GoTo 0
    If Not sheetsListBox Is Nothing Then sheetsListBox.Delete
   
    Set copySheetsButton = Nothing
    On Error Resume Next
    Set copySheetsButton = ActiveSheet.Buttons("Copy Column")
    On Error GoTo 0
    If Not copySheetsButton Is Nothing Then copySheetsButton.Delete
   
End Sub
Thanks again! everything is working as planned now I appreciate you taking your time to code the functions needed! cheers
 
Upvote 0

Forum statistics

Threads
1,213,544
Messages
6,114,249
Members
448,556
Latest member
peterhess2002

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top