Hi I have a working code given to me from another forum for a specific task and added/modified some of it (like which column to copy, intervals, savepath, etc.):
When a button is clicked, it will pop-up a listbox that list all the sheets in the current workbook
When another button is clicked All selected sheet in the listbox will have specific columns copied from each of them (example column F:F of each) and pasted to a new workbook with 1 column interval per paste
now I want to transfer this in my userform w/ listbox and button and a filter for sheetname, I cant figure out how to have the exact same function working
Here is the existing code
Private Sub CommandButton4_Click()
'Generate block file
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
.Top = 15
.Width = 165
.Left = 720
.MultiSelect = xlSimple
For Each ws In ActiveWorkbook.Worksheets
.AddItem ws.Name
Next
End With
With copySheetsButton
.Name = "Copy Column"
.Top = sheetsListBox.Top + sheetsListBox.Height + 5
.Width = 165
.Left = 720
.Caption = "Generate Block File"
.OnAction = "Copy_Column_From_Selected_Sheets"
End With
End Sub
'From module2
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
Dim SavePath As String
Dim fdObj As Object
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
MsgBox "no sheet(s) selected", vbCritical
Exit Sub
Else
End If
NewWsName = InputBox("Input PROJECT File Name" & vbNewLine & "Files are saved on:" & vbNewLine & " :desktop\Excel Exports ", "Exports")
If NewWsName = "" Then
MsgBox "no Project file name entered", vbCritical
Exit Sub
Else
End If
If numSelectedSheets > 0 Then
Set NewWs = ActiveWorkbook.Worksheets.Add(Before:=Worksheets(1))
NewWs.Name = NewWsName
colNumber = 6
For i = 1 To .ListCount
If .Selected(i) Then
ActiveWorkbook.Worksheets(.List(i)).Columns("F:F").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
colNumber = colNumber + 2
ActiveWorkbook.Worksheets(.List(i)).Columns("A:D").Copy
NewWs.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
NewWs.Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
NewWs.Cells(6, colNumber - 2).FormulaR1C1 = .List(i) & " QTY"
End If
Next
Else
MsgBox "No sheet(s) selected", vbCritical
End If
End With
sheetsListBox.Delete
copySheetsButton.Delete
SavePath = CreateObject("WScript.Shell").specialfolders("Desktop")
Application.ScreenUpdating = False
Set fdObj = CreateObject("Scripting.FileSystemObject")
If fdObj.FolderExists(SavePath & "\Excel Exports") Then
Else
fdObj.CreateFolder (SavePath & "\Excel Exports")
End If
Application.ScreenUpdating = True
Sheets(NewWsName).Select
Sheets(NewWsName).Move
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=SavePath & "\Excel Exports\" & NewWsName & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Saved = True
Application.DisplayAlerts = True
Workbooks(NewWsName & ".XLSx").Close SaveChanges:=False
End SubNow I have a userform that list a filtered name of sheets and i want the button of this userform to have the same sequence and function of the working code
Private Sub CommandButton1_Click()
'Generate block file
End Sub
Private Sub UserForm_Initialize()
Dim i As Long
For i = 1 To ActiveWorkbook.Sheets.Count
If Sheets(i).Name Like "CP*" Then
ListBox1.AddItem ActiveWorkbook.Sheets(i).Name
Else
End If
Next
End SubI also attached a sample file with bot the buttons
orange is the working one and pink is the new one
userform4 is the one to be used
module2 has the action code of the working code.
hope someone can help , thanks!
