VBA using a ListBox to apply selections to a Module - vba

Question

I'm relatively new to VBA, so thanks in advance for the advice. I am just dabbling to help out a friend to make his work less repetitive in my free time.
I created a GUI that has 2 ListBoxes that contain the names of the worksheets in the excel file. The left ListBox contains the available worksheets and the right ListBox is the list of worksheets the user chooses to perform the analysis on with the ability to move the names between the 2 ListBoxes. I am trying to link the GUI to my Module I created that performs the actual analysis. Once it is linked, I need the Selections that are made in the GUI to become an array that can be looped through in the Module. I am missing a few pieces, so bear with me please.
Submit Button Code:
Dim Size As Integer
Size = Me. ListBox2 . ListCount - 1
ReDim Selection(0 To Size) As String
Dim i As Integer
For i = 0 To Size
Selection (i) = Me.ListBox2.ItemData(i)
Next i
Unload GUI
The Area in the Module that I want to implement the Selection:
'Only performs copy/paste actions on the worksheets that aren't named "Summary".
For Each sh In ActiveWorkbook. Worksheets
If sh.Name < > DestSh.Name Then
'Sets the Range you want to Copy from the source Worksheets. This range is the set of cells with data in it.
Set CopyRng = sh. UsedRange
The goal is to read the Selections from the GUI, locate the sheet that the Selections are named after and link the selections to the "sh" variable somehow.

Answer 1

Since you are already referencing sh as a Worksheet variable in your code, while the Selections array holds strings, I believe the simplest way would be to shift the For..Each statement to:
For Each sel_item In Selection
and add the line:
Set sh = ActiveWorkbook.Worksheets(sel_item)
You will, of course, also need to edit the Next sh statement to Next sel_item, and add a Dim sel_item as Variant
In other words, the beginning of the loop section will look like:
'Only performs copy/paste actions on the worksheets that aren't named "Summary".
For Each sel_item In Selection
Set sh = ActiveWorkbook.Worksheets(sel_item)
If sh.Name < > DestSh.Name Then
'Sets the Range you want to Copy from the source Worksheets. This range is the set of cells with data in it.
Set CopyRng = sh. UsedRange
Instead of this (original):
'Only performs copy/paste actions on the worksheets that aren't named "Summary".
For Each sh In ActiveWorkbook. Worksheets
If sh.Name < > DestSh.Name Then
'Sets the Range you want to Copy from the source Worksheets. This range is the set of cells with data in it.
Set CopyRng = sh. UsedRange

Answer 2

Delimited Cell Expansion
First adjust the values in the constants section and then read through the whole comments because there might be some issues you wouldn't expect. You can use it on any column containing commas as delimiters, so in your case you can use it on the Base column, too.
Sub DelimitedCellExpansion()
Const cVntWsSource As String = "Sheet1" ' Source Worksheet Name/Index
Const cStrSourceFirst As String = "A1" ' Source First Cell Range of Data
Const cVntSplit As Variant = "D" ' Source Column Letter/Number
Const cVntWsTarget As String = "Sheet2" ' Target Worksheet Name/Index
Const cStrTargetFirst As String = "B1" ' Target First Cell Range of Data
Const cStrSep As String = ",,,|,,|, ," ' Wrong Separators
Dim vntSrc As Variant ' Source Array
Dim vntSep As Variant ' Separator Array
Dim vntSplitData As Variant ' Split Data Array
Dim vntSplit As Variant ' Split Array
Dim vntCol As Variant ' Target Column Array
Dim vntTgt As Variant ' Target Array
Dim intCol As Integer ' Source Array Target Column
Dim lng1 As Long ' Source Array Target Column Rows Count(er)
Dim int1 As Integer ' Separator Array Strings Counter
Dim lng2 As Long ' Target Array Rows Count(er)
Dim int2 As Integer ' Split Data Column Counter
' Source Worksheet Data Extraction
With ThisWorkbook.Worksheets(cVntWsSource)
If Not .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 1) _
Is Nothing Then ' Worksheet has data.
' Paste Source Range into Source Array
vntSrc = .Range(cStrSourceFirst, .Cells(.Cells.Find("*", , , , 1, 2) _
.Row, .Cells.Find("*", , , , 2, 2).Column))
' Calculate Source Array Target Column.
intCol = .Columns(cVntSplit).Column - .Range(cStrSourceFirst).Column + 1
Else ' Worksheet is empty.
GoTo EmptySheetErr
End If
End With
' Split Separator String into Separator Array.
vntSep = Split(cStrSep, "|")
' Introduce Split Data Array
ReDim vntSplitData(1 To UBound(vntSrc))
' Target Array Columns Count
For lng1 = 1 To UBound(vntSrc)
' Clean separators in current field of Target Column.
vntSrc(lng1, intCol) = WorksheetFunction.trim(vntSrc(lng1, intCol))
For int1 = 0 To UBound(vntSep)
vntSrc(lng1, intCol) = Replace(vntSrc(lng1, intCol), _
vntSep(int1), ",")
Next
' Split current field of Target Column.
vntSplit = Split(vntSrc(lng1, intCol), ",")
' Resize Target Column Array.
If Not IsEmpty(vntCol) Then
ReDim Preserve vntCol(1 To UBound(vntCol) + UBound(vntSplit) + 1)
Else
ReDim vntCol(1 To UBound(vntSplit) + 1)
End If
' Copy split values to Target Column Array.
For int1 = 0 To UBound(vntSplit)
vntCol(UBound(vntCol) - UBound(vntSplit) + int1) = trim(vntSplit(int1))
Next
' Collect Split Data.
vntSplitData(lng1) = UBound(vntSplit) + 1
Next
Erase vntSplit
Erase vntSep
' Write data to Target Array
lng2 = 1
ReDim vntTgt(1 To UBound(vntCol), 1 To UBound(vntSrc, 2))
For lng1 = 1 To UBound(vntSrc)
' Write current row of other columns to Target Array.
Select Case intCol
Case 1 ' LBound(vntSrc, 2)
For int1 = 2 To UBound(vntSrc, 2)
vntTgt(lng2, int1) = vntSrc(lng1, int1)
Next
Case UBound(vntSrc, 2)
For int1 = 1 To UBound(vntSrc, 2) - 1
vntTgt(lng2, int1) = vntSrc(lng1, int1)
Next
Case Else
For int1 = 1 To intCol - 1
vntTgt(lng2, int1) = vntSrc(lng1, int1)
Next
For int1 = intCol + 1 To UBound(vntSrc, 2)
vntTgt(lng2, int1) = vntSrc(lng1, int1)
Next
End Select
' Write current row of Source Array Target Column to Target Array.
For int2 = 1 To vntSplitData(lng1)
vntTgt(lng2, intCol) = vntCol(lng2)
lng2 = lng2 + 1
Next
Next
Erase vntCol
' With ThisWorkbook.Worksheets(cVntWsTarget)
' ' Paste Target Array into Target Worksheet.
' .Range(cStrTargetFirst).Resize(UBound(vntTgt), UBound(vntTgt, 2)) = vntTgt
' End With
' This would have been the end, if there was no formatting to do.
' Introducing a Range object.
Dim objRng As Range
Set objRng = ThisWorkbook.Worksheets(cVntWsTarget) _
.Range(cStrTargetFirst).Resize(UBound(vntTgt), UBound(vntTgt, 2))
'***************************************
' This is necessary if there are merged cells in the Target Range.
' This clears the whole Target Worksheet.
objRng.Parent.Cells.Clear
' This clears only the Target Range.
' objRng.Cells.Clear
'***************************************
' Paste Target Array into Target Range of Target Worksheet.
objRng = vntTgt
Erase vntTgt
With objRng
' Paste formatting from first row down to the last.
.Cells(1, 1).Resize(, .Columns.Count).Copy ' Copy first row.
.PasteSpecial Paste:=xlPasteFormats ' Paste formatting down to last.
' The Target Range is selected and is flickering. Therefore:
Application.CutCopyMode = False ' Target Range still selected.
'***********************************************************
' Apply formatting (merge)
'***********************************************************
' This is up to you. I have done only some easy formatting.
' With .Interior
' .ColorIndex = xlNone
' .Pattern = xlSolid
' .PatternColorIndex
' End With
' ' Font
' With .Font
' .Name = "Verdana"
' .Size = 10
' .Strikethrough = False
' .Superscript = False
' .Subscript = False
' .OutlineFont = False
' .Shadow = False
' .Underline = xlUnderlineStyleNone
' .ColorIndex = xlAutomatic
' .Bold = True
' End With
' Borders
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
lng2 = 1
For lng1 = 1 To UBound(vntSrc)
' Write current row of other columns to Target Array.
Select Case intCol
Case 1 ' LBound(vntSrc, 2)
For int1 = 2 To UBound(vntSrc, 2): GoSub OtherFormat: Next
Case UBound(vntSrc, 2)
For int1 = 1 To UBound(vntSrc, 2) - 1: GoSub OtherFormat: Next
Case Else
For int1 = 1 To intCol - 1: GoSub OtherFormat: Next
For int1 = intCol + 1 To UBound(vntSrc, 2): GoSub OtherFormat: Next
End Select
GoSub TargetFormat
lng2 = lng2 + vntSplitData(lng1)
Next
Erase vntSplitData
Erase vntSrc
GoTo FormatEnd
'***********************************************************
' This is created to easily adjust (change) formatting.
' The formatting applies only to the Data range.
'***********************************************************
OtherFormat: ' Format other columns.
With .Cells(lng2, int1).Resize(vntSplitData(lng1))
If vntSplitData(lng1) > 1 Then ' Multiple rows.
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
Else ' One row only.
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End If
End With
Return
TargetFormat: ' Format Target Column.
With .Cells(lng2, intCol).Resize(vntSplitData(lng1))
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Return
FormatEnd:
' Only autofits the Target Range.
' .Columns.AutoFit
' Autofit from top.
.Columns.EntireColumn.AutoFit
'***********************************************************
End With
ProcedureExit:
Set objRng = Nothing
Exit Sub
EmptySheetErr:
MsgBox "You're in an empty sheet."
GoTo ProcedureExit
End Sub