I am trying to develop a function that will take an array of results containing duplicate values and return an array containing only the duplicated values. The code below does work but I wonder if there is a more elegant / shorter solution?
Sub test()
Dim allFruits(9) As String, manyFruits() As String
allFruits(0) = "plum"
allFruits(1) = "apple"
allFruits(2) = "orange"
allFruits(3) = "banana"
allFruits(4) = "melon"
allFruits(5) = "plum"
allFruits(6) = "kiwi"
allFruits(7) = "nectarine"
allFruits(8) = "apple"
allFruits(9) = "grapes"
manyFruits = duplicates(allFruits())
End Sub
Function duplicates(allFound() As String)
Dim myFound() As String
Dim i As Integer, e As Integer, c As Integer, x As Integer
Dim Comp1 As String, Comp2 As String
Dim found As Boolean
If Len(Join(allFound)) > 0 Then 'Check string array initialised
If UBound(allFound) > 0 Then
For c = 0 To UBound(allFound) 'Pass ONLY the duplicates
Comp1 = allFound(c)
If Comp1 > "" Then
For x = c + 1 To UBound(allFound)
Comp2 = allFound(x)
If Comp1 = Comp2 Then
found = True
ReDim Preserve myFound(0 To i)
myFound(i) = Comp1
i = i + 1
For e = x To UBound(allFound) 'Delete forward instances of found item
If allFound(e) = Comp1 Then
allFound(e) = ""
End If
Next e
Exit For
End If
Next x
End If
Next c
Else 'Just one found
ReDim myFound(0 To 0)
myFound(0) = allFound(0)
found = True
End If
End If
duplicates = myFound
End Function
Double Dictionary
As String (Exactly the Same Functionality)
Sub test1()
Dim allFruits(9) As String, manyFruits() As String
allFruits(0) = "plum"
allFruits(1) = "apple"
allFruits(2) = "orange"
allFruits(3) = "banana"
allFruits(4) = "melon"
allFruits(5) = "plum"
allFruits(6) = "kiwi"
allFruits(7) = "nectarine"
allFruits(8) = "apple"
allFruits(9) = "grapes"
manyFruits = Duplicates1(allFruits())
Debug.Print Join(manyFruits, vbLf)
End Sub
Function Duplicates1(StringArray() As String) As String()
Dim sDict As Object: Set sDict = CreateObject("Scripting.Dictionary")
sDict.CompareMode = vbTextCompare
Dim dDict As Object: Set dDict = CreateObject("Scripting.Dictionary")
dDict.CompareMode = vbTextCompare
Dim n As Long
For n = LBound(StringArray) To UBound(StringArray)
If sDict.Exists(StringArray(n)) Then
dDict(StringArray(n)) = Empty
Else
sDict(StringArray(n)) = Empty
End If
Next n
If dDict.Count = 0 Then Exit Function
Set sDict = Nothing
Dim arr() As String: ReDim arr(0 To dDict.Count - 1)
Dim Key As Variant
n = 0
For Each Key In dDict.Keys
arr(n) = Key
n = n + 1
Next Key
Duplicates1 = arr
End Function
As Variant (Shorter But Different see ' ***)
Sub test2()
Dim allFruits(9) As String, manyFruits() As Variant ' *** here
allFruits(0) = "plum"
allFruits(1) = "apple"
allFruits(2) = "orange"
allFruits(3) = "banana"
allFruits(4) = "melon"
allFruits(5) = "plum"
allFruits(6) = "kiwi"
allFruits(7) = "nectarine"
allFruits(8) = "apple"
allFruits(9) = "grapes"
manyFruits = Duplicates2(allFruits())
Debug.Print Join(manyFruits, vbLf)
End Sub
Function Duplicates2(StringArray() As String) As Variant ' *** here
Dim sDict As Object: Set sDict = CreateObject("Scripting.Dictionary")
sDict.CompareMode = vbTextCompare
Dim dDict As Object: Set dDict = CreateObject("Scripting.Dictionary")
dDict.CompareMode = vbTextCompare
Dim n As Long
For n = LBound(StringArray) To UBound(StringArray)
If sDict.Exists(StringArray(n)) Then
dDict(StringArray(n)) = Empty
Else
sDict(StringArray(n)) = Empty
End If
Next n
Duplicates2 = dDict.Keys
End Function
Short approach via FilterXML()
This approach
transforms the base array allFruits into a wellformed xml content using name attributes (nm) and
applies an XPath expression upon all nodes filtering only nodes with siblings via
"fruits/fruit[(#nm = following-sibling::fruit/#nm)]/#nm"
Instead of explicitly referring to fruits you could also start XPath with //fruit[..." where the double slashes indicate a search at any hierarchy level.
Function MoreThanOne(arr)
'Purp: get only fruits with multiple occurrencies
'Note: reads top to bottom returning the last(!) attribute #nm
' based on the condition of no following fruit sibling,
'a) create a wellformed xml content string
Dim content As String
content = _
"<fruits><fruit nm='" & _
Join(arr, "'/><fruit nm='") & _
"'/></fruits>"
'b) define XPath expression
Dim XPth As String
XPth = "/fruits/fruit[(#nm = following-sibling::fruit/#nm)]/#nm" ' multiple occurrencies
'c) apply FilterXML function
Dim x: x = Application.FilterXML(content, XPth)
'd) return result(s)
MoreThanOne = Application.Transpose(x)
Select Case VarType(x)
Case vbError
MoreThanOne = Array("Nothing found")
Case vbString
MoreThanOne = Array(x)
Case Else
MoreThanOne = Application.Transpose(x)
End Select
End Function
Example call
Sub testMoreThanOne()
Dim allFruits(9) As String, manyFruits() As Variant
allFruits(0) = "plum"
allFruits(1) = "apple"
allFruits(2) = "orange"
allFruits(3) = "banana"
allFruits(4) = "melon"
allFruits(5) = "plum"
allFruits(6) = "kiwi"
allFruits(7) = "nectarine"
allFruits(8) = "apple"
allFruits(9) = "grapes"
manyFruits = MoreThanOne(allFruits)
Debug.Print Join(manyFruits, vbLf) ' ~~> plum|apple
End Sub
Schema of the created xml structure by above array joins
<fruits>
<fruit nm='plum'/>
<fruit nm='apple'/>
<fruit nm='orange'/>
<fruit nm='banana'/>
<fruit nm='melon'/>
<fruit nm='plum'/>
<fruit nm='kiwi'/>
<fruit nm='nectarine'/>
<fruit nm='apple'/>
<fruit nm='grapes'/>
</fruits>
Side note
Of course you might want to get just uniques by only negating the XPath condition in brackets via
XPth = "/fruits/fruit[not(#nm = following-sibling::fruit/#nm)]/#nm"
My solution...
Sub FindDuplicates()
Dim VarDat As Variant
Dim lngz As Long, lngz2 As Long, lngF As Long
Dim objDict As Object
Dim b As Boolean
With Sheet1
Set objDict = CreateObject("Scripting.Dictionary")
VarDat = .Range("A1:A20").Value2
For lngz = 1 To UBound(VarDat, 1)
For lngz2 = lngz + 1 To UBound(VarDat, 1)
If VarDat(lngz, 1) = VarDat(lngz2, 1) Then
b = True
Exit For
End If
Next lngz2
If b = True Then
If objDict.Exists(VarDat(lngz, 1)) = False Then
objDict.Add VarDat(lngz, 1), 0
End If
b = False
End If
Next lngz
.Range("D:D").Clear
.Range("D1:D" & objDict.Count) = Application.Transpose(objDict.keys)
End With
End Sub
I am doing my homework but stuck on a part. Problem is, How can i populate seat number in array of controls(labels) using database. I already created labels and a class to retrieve all rows from database but how can i apply it in main form and populate labels.
--------------------------Class---------------------------------------
Public Shared Function getOneRow(PK As Integer) As datMovieTimes
Dim returnRow As New datMovieTimes(0)
Dim connDB As New SqlConnection
connDB.ConnectionString = Conn.getConnectionString
Dim command As New SqlCommand
command.Connection = connDB
command.CommandType = CommandType.Text
command.CommandText = SQLStatements.SELECT_1_BY_ID
command.Parameters.AddWithValue("#Key", PK)
Try
connDB.Open()
Dim dR As IDataReader = command.ExecuteReader
If dR.Read() Then
returnRow.showingID = PK
If Not IsDBNull(dR(Fields.movieID)) Then returnRow.movieID = dR(Fields.movieID)
If Not IsDBNull(dR(Fields.dateTime)) Then returnRow.dateTime = dR(Fields.dateTime)
If Not IsDBNull(dR(Fields.isActive)) Then returnRow.isActive = dR(Fields.isActive)
End If
Catch ex As Exception
Console.WriteLine(Err.Description)
End Try
Return returnRow
End Function
Public Shared Function getAllRows() As Generic.List(Of datMovieTimes)
Dim returnRows As New Generic.List(Of datMovieTimes)
Dim connDB As New SqlConnection
connDB.ConnectionString = Conn.getConnectionString
Dim command As New SqlCommand
command.Connection = connDB
command.CommandType = CommandType.Text
command.CommandText = SQLStatements.SELECT_ALL
Try
connDB.Open()
Dim dR As IDataReader = command.ExecuteReader
Do While dR.Read()
Dim Row As New datMovieTimes(0)
If Not IsDBNull(dR(Fields.showingID)) Then Row.showingID = dR(Fields.showingID)
If Not IsDBNull(dR(Fields.movieID)) Then Row.movieID = dR(Fields.movieID)
If Not IsDBNull(dR(Fields.dateTime)) Then Row.dateTime = dR(Fields.dateTime)
If Not IsDBNull(dR(Fields.isActive)) Then Row.isActive = dR(Fields.isActive)
returnRows.Add(Row)
Loop
Catch ex As Exception
Console.WriteLine(Err.Description)
End Try
Return returnRows
End Function
-----------------------------main form-----------------------------------------
Public Sub createSeat()
Dim S1 As Label
For X As Integer = 1 To _MAX_X
For Y As Integer = 1 To _MAX_Y
S1 = New Label
S1.Height = 25
S1.Width = 25
S1.BackColor = Color.LightGreen
S1.Top = 100 + (X - 1) * (S1.Height + 5)
S1.Left = 200 + (Y - 1) * (S1.Width + 5)
S1.TextAlign = ContentAlignment.MiddleCenter
S1.Text = Y.ToString
AddHandler S1.Click, AddressOf GenericLabel_Click
Me.Controls.Add(S1)
_SeatArray(X, Y) = S1
Next
Next
For X As Integer = 0 To 9
_AlphaLabel(X) = New Label
_AlphaLabel(X).Height = 25
_AlphaLabel(X).Width = 25
_AlphaLabel(X).BackColor = Color.Transparent
_AlphaLabel(X).Top = 130 + (X - 1) * (_AlphaLabel(X).Height + 6)
_AlphaLabel(X).Left = 170
_AlphaLabel(X).Text = _AlphaName(X)
Me.Controls.Add(_AlphaLabel(X))
Next
End Sub
Private Sub GenericLabel_Click(sender As Object, e As EventArgs)
Dim L As New Label
L = DirectCast(sender, Label)
If L.BackColor = Color.LightGreen Then
L.BackColor = Color.Orange
clickLess -= 1
ElseIf L.BackColor = Color.Orange Then
L.BackColor = Color.LightGreen
clickLess += 1
End If
clickCount += 1
Me.lblRemainingCount.Text = clickLess.ToString
Me.nudTicketsCount.Value = clickCount
If clickLess <= 0 Then
MsgBox("No more seats left.", MsgBoxStyle.OkOnly, "House Full")
End If
End Sub
Database pic
When creating labels, insert one more line:
S1.Name = "MyLabel" & X & Y
When accessing the label:
Dim MyCurrentLabel as Label
MyCurrentLabel = CType("MyLabel" & X & Y, Label)
Then you can do things with the current label:
MyCurrentLabel.Text = "Hello World"
current image
Now it is something like this, so it want to change the colour to red if it is paid according to database.
Thanks
I found the answer, sorry i forgot to mention it because i was busy in completing the project
----------------------Seat creation----------------------------------------
Public Sub createSeat()
Dim S1 As Label
Dim numValue As Integer = 1
For X As Integer = 1 To _MAX_X
For Y As Integer = 1 To _MAX_Y
S1 = New Label
S1.Height = 25
S1.Width = 25
S1.BackColor = Color.LightGreen
S1.Top = 180 + (X - 1) * (S1.Height + 5)
S1.Left = 200 + (Y - 1) * (S1.Width + 5)
S1.TextAlign = ContentAlignment.MiddleCenter
S1.Text = Y.ToString
' S1.Text = numValue
S1.Name = "Label" & numValue
AddHandler S1.Click, AddressOf GenericLabel_Click
Me.Controls.Add(S1)
_SeatArray(X, Y) = S1
numValue += 1
Next
Next
For X As Integer = 0 To 9
_AlphaLabel(X) = New Label
_AlphaLabel(X).Height = 25
_AlphaLabel(X).Width = 25
_AlphaLabel(X).BackColor = Color.Transparent
_AlphaLabel(X).Top = 210 + (X - 1) * (_AlphaLabel(X).Height + 6)
_AlphaLabel(X).Left = 170
_AlphaLabel(X).Text = _AlphaName(X)
Me.Controls.Add(_AlphaLabel(X))
Next
End Sub
-------------------------------populate seat number----------------------------------
Public Sub populateSeatNumber()
Dim connectionString As String = DBL.Conn.getConnectionString
Dim connection As New SqlConnection(connectionString)
connection.Open()
Dim selectStatement As String = "SELECT * FROM datTicketsSold"
Dim selectCommand As New SqlCommand(selectStatement, connection)
Dim daSoldTickets As New SqlDataAdapter(selectCommand)
Dim dsSoldTickets As DataSet = New DataSet
daSoldTickets.Fill(dsSoldTickets, "datTicketsSold")
connection.Close()
Dim dtTickets As DataTable = dsSoldTickets.Tables("datTicketsSold")
Dim row As DataRow
For Each row In dtTickets.Rows
If row(3) = True Then
CType(Controls("Label" & row(2)), Label).BackColor = Color.Red
redCounter += 1
Else
CType(Controls("Label" & row(2)), Label).BackColor = Color.Yellow
yellowCounter += 1
End If
Next
Me.lblReservedCount.Text = yellowCounter.ToString
Me.lblSoldCount.Text = redCounter.ToString
End Sub
Thanks everyone
We have a series of ListBoxes - when an item in the main ListBox is selected the relevant values are displayed in the sub ListBox. This works as intended...
We also have the ability to move items up or down, and this works as intended...
When the main ListBox has the SelectionChanged event wired up the ability to move items up and down in the sub list box stops working. Comment that out and up/down works again in the sub ListBox... I must have overlooked something glaringly obvious but after numerous changes still can't get it to work
Main ListBox SelectionChanged
Private Sub Reports_CashFlow_ListBox_IndexChanged(ByVal MainLB As String, ByVal NominalLB As String, ByVal NomDT As DataTable)
Try
Dim LB As LBx = ReportCashFlow_Grid.FindName(MainLB)
If LB.SelectedIndex = -1 Then
Exit Sub
End If
Dim NomLB As LBx = ReportCashFlow_Grid.FindName(NominalLB)
If NomLB Is Nothing Then
Exit Sub
End If
If LB.SelectedValue Is Nothing Then
Exit Sub
End If
If LB.SelectedValue.GetType.Name Is Nothing Then
Exit Sub
End If
If LB.SelectedValue.GetType.Name <> "DataRowView" Then
Dim CatID As Integer = LB.SelectedValue
Dim DV As New DataView(NomDT)
DV.RowFilter = "CatID = " & CatID & " AND FormID = " & Form_ID
DV.Sort = "Position"
With NomLB
.ItemsSource = DV
.Items.Refresh()
End With
LB.ScrollIntoView(LB.SelectedItem)
End If
Catch ex As Exception
EmailError(ex)
End Try
End Sub
Move items up
Private Sub Reports_BalanceSheet_ListBoxMoveUp(LB As ListBox, DT As DataTable, DisplayName As String, Optional MasterListBox As ListBox = Nothing)
Try
Dim StartIndex As Integer = LB.SelectedIndex
If StartIndex = -1 Then
AppBoxValidation("You have not selected an item to move up!")
Exit Sub
End If
If Not StartIndex = 0 Then
Dim CatID As Integer = 0
If DisplayName = "NomName" Then
CatID = MasterListBox.SelectedValue
End If
Dim vSelected As DataRow = DT.Rows(StartIndex)
Dim vNew As DataRow = DT.NewRow()
vNew.ItemArray = vSelected.ItemArray
DT.Rows.Remove(vSelected)
DT.Rows.InsertAt(vNew, StartIndex - 1)
DT.AcceptChanges()
LB.SelectedIndex = StartIndex - 1
Dim vPos As Integer = 0
For Each Row As DataRow In DT.Rows
If Not CatID = 0 Then
If Row("CatID") = CatID Then
Row("Position") = vPos
vPos += 1
End If
Else
Row("Position") = vPos
vPos += 1
End If
Next
LB.Items.Refresh()
End If
Catch ex As Exception
EmailError(ex)
End Try
End Sub
Turns out the issue related to subsets of data in the DataView - so needed to find the correct index for the selected item and the replacement index in the entire back-end table
Private Sub Reports_BalanceSheet_ListBoxMoveUp(LB As ListBox, DT As DataTable, DisplayName As String, Optional MasterListBox As ListBox = Nothing)
Try
Dim StartIndex As Integer = LB.SelectedIndex
If StartIndex = -1 Then
AppBoxValidation("You have not selected an item to move up!")
Exit Sub
End If
If Not StartIndex = 0 Then
Dim CatID As Integer = 0
If DisplayName = "NomName" Then
CatID = MasterListBox.SelectedValue
'As the view could be a subset of data we need to find the actual back end DB index
Dim SelectedID As Integer = LB.SelectedValue
Dim DR() As DataRow = DT.Select("ID = " & SelectedID, Nothing)
Dim vIndex As Integer = DT.Rows.IndexOf(DR(0))
Dim vCurrentPos As Integer = DR(0)("Position")
'Find the index of the one above in the grid
Dim DR2() As DataRow = DT.Select("CatID = " & CatID & " AND Position = " & vCurrentPos - 1, Nothing)
Dim vIndex2 As Integer = DT.Rows.IndexOf(DR2(0))
Dim vSelected As DataRow = DT.Rows(vIndex)
Dim vNew As DataRow = DT.NewRow()
vNew.ItemArray = vSelected.ItemArray
DT.Rows.Remove(vSelected)
DT.Rows.InsertAt(vNew, vIndex2)
DT.AcceptChanges()
Else
Dim vSelected As DataRow = DT.Rows(StartIndex)
Dim vNew As DataRow = DT.NewRow()
vNew.ItemArray = vSelected.ItemArray
DT.Rows.Remove(vSelected)
DT.Rows.InsertAt(vNew, StartIndex - 1)
DT.AcceptChanges()
End If
Dim vPos As Integer = 0
For Each Row As DataRow In DT.Rows
If Not CatID = 0 Then
If Row("CatID") = CatID Then
Row("Position") = vPos
vPos += 1
End If
Else
Row("Position") = vPos
vPos += 1
End If
Next
LB.SelectedIndex = StartIndex - 1
End If
Catch ex As Exception
EmailError(ex)
End Try
End Sub
In an older WinForms app this worked, but in WPF it will move the item only once, the only current workaround is the save it to the back end DB, open again and move one more space. The list items are supplied by a DataTable
Private Sub Reports_BalanceSheet_ListBoxMoveUp(LB As ListBox, DT As DataTable, DisplayName As String, Optional MasterListBox As ListBox = Nothing)
Try
Dim StartIndex As Integer = LB.SelectedIndex
Dim CatID As Integer = 0
'Update the datasource
Dim SR() As DataRow
If DisplayName = "Name" Then
SR = DT.Select("ID > 0 AND FormID = " & Form_ID, Nothing)
Else
CatID = MasterListBox.SelectedValue
'Check that the positions are correct
If DataChanged = False Then
Dim vRowID As Integer = 0
For Each Row As DataRow In DT.Rows
If Row("FormID") = Form_ID And Row("CatID") = CatID Then
Row("Position") = vRowID
vRowID += 1
End If
Next
End If
SR = DT.Select("ID > 0 AND FormID = " & Form_ID & " AND CatID = " & CatID, "Position")
End If
Dim vString As String = ""
Dim vUpperID As Integer = 0
Dim vCurrentID As Integer = 0
For Each Row As DataRow In SR
Dim vPos As Integer = Row("Position")
If vPos = StartIndex - 1 Then
vUpperID = Row("ID")
End If
If vPos = StartIndex Then
vCurrentID = Row("ID")
End If
Next
If Not vUpperID = 0 And Not vCurrentID = 0 Then
DT.Select("ID = " & vUpperID)(0)("Position") = StartIndex
DT.Select("ID = " & vCurrentID)(0)("Position") = StartIndex - 1
If DisplayName = "Name" Then
DT.DefaultView.RowFilter = "FormID = " & Form_ID
Else
DT.DefaultView.RowFilter = "FormID = " & Form_ID & " AND CatID = " & CatID
End If
DT.DefaultView.Sort = "Position"
DT = DT.DefaultView.ToTable
DT.AcceptChanges()
With LB
.SelectedValuePath = "ID"
.DisplayMemberPath = DisplayName
.ItemsSource = DT.DefaultView
.SelectedValue = vCurrentID
.UpdateLayout()
End With
End If
Catch ex As Exception
EmailError(ex)
End Try
End Sub
Got it working this way (and with less code) :-)
Dim StartIndex As Integer = LB.SelectedIndex
Dim vTotalRows As Integer = DT.Rows.Count - 1
If Not StartIndex = vTotalRows Then
Dim vSelected As DataRow = DT.Rows(StartIndex)
Dim vNew As DataRow = DT.NewRow()
vNew.ItemArray = vSelected.ItemArray
DT.Rows.Remove(vSelected)
DT.Rows.InsertAt(vNew, StartIndex + 1)
LB.SelectedIndex = StartIndex + 1
Dim vPos As Integer = 0
For Each Row As DataRow In DT.Rows
Row("Position") = vPos
vPos += 1
Next
End If
I am working on a project, which takes a checksheet that the user creates and fills out
and, when the user runs a macro, creates a new workbook that extrapolates and expands the checksheet data, as shown here
What it does is it goes through each of those number labor codes, and runs down the checksheet for all the applicable items, addending them to the list.
Now...I have this working fine, and run through the basic testing. I save the checksheet as an array and pass it through to the new workbook, filtering and creating the new workbook line-by-line.
I just can't help but think that there's a much easier way to do this, as the way I'm doing it now just doesn't seem to be the simplest and most stable way.
I'm open to sharing my code I have so far, but was wondering if you were given this senario, how you would approach it.
Here is the link to my file: https://www.dropbox.com/s/2gobdx1rcabquew/Checksheet_Template_R3.0%20-%20StkOvrflw.xls
Main module, which checks for errors and corrects formatting:
Option Explicit
Public FamilyName As String
Public ModelName As String
Public TaskArray() As Variant
Public TaskArrayRowCount As Integer
Public TaskArrayColCount As Integer
Sub CreateTemplate()
Application.EnableEvents = False
Application.ScreenUpdating = False
'Main SubModule. Runs Formatting and Template Generation
Dim thisWB As Workbook
Dim TaskArray() As Variant
Dim i As Range
Dim MajMinYesNo As Boolean
Dim OPOYesNo As Boolean
If MsgBox("Are you ready to generate the Template?", vbYesNo, "Ready?") = vbNo Then
Application.EnableEvents = True
Application.ScreenUpdating = True
End
End If
MajMinYesNo = False
OPOYesNo = False
Set thisWB = ActiveWorkbook
FamilyName = thisWB.Names("Family_Name").RefersToRange
ModelName = thisWB.Names("Model_No").RefersToRange
Call CreateArray(thisWB)
'Scans Form_Type Column for "R", "S", or "A-E"
For Each i In Range("CS_FormType")
If i Like "[RS]" Then
MajMinYesNo = True
ElseIf i Like "[A-E]" Then
OPOYesNo = True
End If
Next
'Generates Templates As Needed
If MajMinYesNo Then
If MsgBox("Generate Major/Minor Template?", vbYesNo) = vbYes Then
Call MajorMinor_Generate.GenerateMajorMinor(thisWB)
End If
End If
If OPOYesNo Then
If MsgBox("Generate OPO Template?", vbYesNo) = vbYes Then
Call OPO_Generate.GenerateOPO(thisWB)
End If
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox ("DONE!")
End Sub
Sub CreateArray(thisWB As Workbook)
'Checks formatting and creates array TaskArray() with all the checksheet data
With thisWB.Sheets(1)
'Confirms equal number of rows in columns "CS_TaskNo", "CS_FormType", and "CS_Task"
If (Not Range("CS_TaskNo").Rows.count = Range("CS_FormType").Rows.count) _
Or (Not Range("CS_TaskNo").Rows.count = Range("CS_Task").Rows.count) Then
MsgBox ("Task_No, Form_Type, and Task_Desc row count does not match. Please fix and try again")
Application.EnableEvents = True
Application.ScreenUpdating = True
End
End If
Call FormatCheck
Application.Union(Range("CS_Heading"), Range("CS_TaskNo"), Range("CS_FormType"), Range("CS_Task"), Range("CS_LaborCodes"), Range("CS_Checks")).Name = "TaskArray"
TaskArrayRowCount = Range("TaskArray").Rows.count
TaskArrayColCount = Range("TaskArray").Columns.count
ReDim TaskArray(TaskArrayRowCount, TaskArrayColCount)
TaskArray = Range("TaskArray").Value
End With
End Sub
Sub FormatCheck()
'Checks for valid labor codes and Form Types
If (Not CheckFormType()) Or (Not CheckLC()) Then
MsgBox ("Errors found, please check red-highlighted cells")
Application.EnableEvents = True
Application.ScreenUpdating = True
End
End If
End Sub
Function CheckFormType()
'Returns False if there's a bad Form_Type entry in range "CS_FormType", True if all OK
Dim i As Range
Dim ReturnVal As Boolean
ReturnVal = True
For Each i In Range("CS_FormType")
Trim (UCase(i.Value))
If Not (i Like "[ABCDEFRS]") Then
Highlight (Cells(i.Row, i.Column))
ReturnVal = False
End If
Next
CheckFormType = ReturnVal
End Function
Function CheckLC()
'Returns False if there's a bad error code, True if all OK _
Formats labor code ranges to add spaces as needed and checks _
labor codes for proper format (###X or ##X). Skips any labor _
codes starting with "28X"
Dim LaborCode As String
Dim LaborCodeLength As Integer
Dim i As Range
Dim j As Integer
Dim LCCell As Range
Dim LCArray() As String
Dim ReturnVal As Boolean
ReturnVal = True
For Each i In Range("CS_LaborCodes")
Trim (UCase(i.Value))
LaborCode = i.Value
If Not Left(LaborCode, 3) Like "28?" Then
LaborCodeLength = Len(LaborCode)
'If string LaborCode is > 4, safe to assume it is a range of labor codes 123A-123F
Select Case LaborCodeLength
Case Is > 4
'Formats Labor Code Range String by adding spaces if necessary (i.e. 123A-123F to 123A - 123F)
For j = 2 To LaborCodeLength Step 1
If (IsNumeric(Mid(LaborCode, j, 1))) And Not IsNumeric(Mid(LaborCode, j + 1, 1)) And Not (Mid(LaborCode, j + 2, 1) = " ") Then
LaborCode = Left(LaborCode, j + 1) & " " & Mid(LaborCode, j + 2)
ElseIf IsNumeric(Mid(LaborCode, j, 1)) And Not (Mid(LaborCode, j - 1, 1) = " ") And Not IsNumeric(Mid(LaborCode, j - 1, 1)) Then
LaborCode = Left(LaborCode, j - 1) & " " & Mid(LaborCode, j)
End If
Next
i = LaborCode
LCArray = Split(LaborCode, " ")
'confirms the labor codes are valid
If (Not IsLaborCode(LCArray(0))) Or (Not IsLaborCode(LCArray(2))) Or (Not IsLaborCodeRange(LCArray(0), LCArray(2))) Then
Highlight (Cells(i.Row, i.Column))
ReturnVal = False
End If
Case 0 To 4
If Not (IsLaborCode(LaborCode)) Then
Highlight (Cells(i.Row, i.Column))
ReturnVal = False
End If
Case Else
Highlight (Cells(i.Row, i.Column))
ReturnVal = False
End Select
End If
Next
CheckLC = ReturnVal
End Function
Function IsLaborCode(LC As String) As Boolean
'returns True if Labor Code is valid, False if invalid _
Labor Code is valid if it is 2 or 3 numbers followed by a letter _
labor code format : ###X or ##X
If LC Like "###[A-Z]" Or LC Like "##[A-Z]" Then
IsLaborCode = True
Else
IsLaborCode = False
End If
End Function
Function IsLaborCodeRange(LCOne As String, LCTwo As String) As Boolean
'returns True if the LC range is valid, False if invalid. _
checks the numerical values to make sure they match and _
makes sure the letters are ascending
If (StrComp(Left(LCOne, Len(LCOne) - 1), Left(LCTwo, Len(LCTwo) - 1)) = 0) And LCOne < LCTwo Then
IsLaborCodeRange = True
Else
IsLaborCodeRange = False
End If
End Function
And here is the other module which actually takes the array and creates the new workbook:
Sub GenerateMajorMinor(thisWB As Workbook)
Dim newWB As Workbook
Dim MajMinArray() As Variant
Set newWB = Workbooks.Add
With newWB
Call FormatWorkbook
Call CreateMajMinArray(newWB, MajMinArray)
Call PopulateItemMaster(MajMinArray)
Call PopulateLaborLink(MajMinArray)
Call SaveFile(newWB, thisWB)
End With
End Sub
Sub SaveFile(newWB As Workbook, thisWB As Workbook)
'saves new workbook into the same file path as the checksheet
Dim i As Integer
Dim FileSavePath As String
Dim FamNameSave As String
FamNameSave = Replace(FamilyName, "/", "_")
i = 1
FileSavePath = thisWB.Path + "/Template (Minor and Major)_" + FamNameSave + ".xls"
a: If Dir(FileSavePath) <> "" Then
FileSavePath = thisWB.Path + "/Template (Minor and Major)_" + FamNameSave + "(" + CStr(i) + ").xls"
i = i + 1
GoTo a:
End If
newWB.SaveAs FileSavePath, FileFormat:=56
End Sub
Sub FormatWorkbook()
'Names and formats sheets
Sheets(1).Name = "Item_Master"
Sheets(2).Name = "Labor_Link"
With Sheets(1)
.Range("A1") = "Company_No"
.Range("B1") = "Family_Name"
.Range("C1") = "Form_Type"
.Range("D1") = "Record_Status"
.Range("E1") = "Task_Desc"
.Range("F1") = "Task_No"
.Range("G1") = "Task_Seq"
.Range("H1") = "Is_Parametric"
End With
With Sheets(2)
.Range("A1") = "Company_Name"
.Range("B1") = "Family_Name"
.Range("C1") = "Form_Type"
.Range("D1") = "Labor_Code"
.Range("E1") = "Print_Control"
.Range("F1") = "Record_Status"
.Range("G1") = "Task_No"
End With
End Sub
Sub CreateMajMinArray(newWB As Workbook, MajMinArray As Variant)
'creates array, removing any OPO/BTS labor codes
With Sheets(3)
Application.EnableEvents = True
Application.ScreenUpdating = True
Dim rng As Range
Set rng = .Range(.Range("A1"), .Cells(TaskArrayRowCount, TaskArrayColCount))
rng = TaskArray
For i = 1 To .Range("A1").End(xlDown).Row Step 1
If .Cells(i, 2) Like "[A-E]" Then
.Rows(i).Delete
i = i - 1
End If
Next
For i = 1 To .Range("A1").End(xlToRight).Column Step 1
If Left(.Cells(1, i), 3) Like "28E" Then
.Columns(i).Delete
i = i - 1
End If
Next
ReDim MajMinArray(.Range("A1").End(xlDown).Row, .Range("A1").End(xlToRight).Column)
MajMinArray = .Range(.Range("A1"), .Cells(.Range("A1").End(xlDown).Row, .Range("A1").End(xlToRight).Column)).Value
.Cells.Clear
End With
End Sub
Sub PopulateItemMaster(MajMinArray As Variant)
With Sheets(1)
'Populates "Item_Master" Sheet
For i = 2 To UBound(MajMinArray) Step 1
.Cells(i, 2) = FamilyName
.Cells(i, 3) = MajMinArray(i, 2)
.Cells(i, 4) = "1"
.Cells(i, 5) = MajMinArray(i, 3)
.Cells(i, 6) = MajMinArray(i, 1)
.Cells(i, 7) = MajMinArray(i, 1)
Next
End With
End Sub
Sub PopulateLaborLink(MajMinArray As Variant)
Dim i As Integer
Dim LaborCode As String
Dim RowCount As Long
Dim LCArray() As String
Dim LastLetter As String
Dim LastFormType As String
'Initializes RowCount and PrintControl
RowCount = 2
PrintControl = 10
With Sheets(2)
For i = 4 To UBound(MajMinArray, 2) Step 1
LaborCode = Trim(MajMinArray(1, i))
'If Labor Code String length is > 4, safe to assume that it is a range of labor codes
Select Case Len(LaborCode)
Case Is > 4
LCArray = Split(LaborCode, " ")
'checks to see if LCArray(0) and LCArray(2) has values
If LCArray(0) = "" Or LCArray(2) = "" Then
MsgBox ("Error with Labor Code range. Please check and re-run")
Application.EnableEvents = True
Application.ScreenUpdating = True
End
End If
LastLetter = Chr(Asc(Right$(LCArray(2), 1)) + 1)
LCArray(2) = Replace(LCArray(2), Right$(LCArray(2), 1), LastLetter)
Do
Call PrintLaborLinkLines(MajMinArray, LCArray(0), RowCount, i)
LastLetter = Chr(Asc(Right$(LCArray(0), 1)) + 1)
LCArray(0) = Replace(LCArray(0), Right$(LCArray(0), 1), LastLetter)
Loop Until LCArray(0) = LCArray(2)
Erase LCArray()
Case Is <= 4
Call PrintLaborLinkLines(MajMinArray, LaborCode, RowCount, i)
End Select
Next
End With
End Sub
Sub PrintLaborLinkLines(MajMinArray As Variant, LaborCode As String, RowCount As Long, i As Integer)
Dim PrintControl As Long
PrintControl = 10
With Sheets(2)
For x = 2 To UBound(MajMinArray) Step 1
If UCase(MajMinArray(x, i)) = "Y" Then
If LastFormType <> MajMinArray(x, 2) Then
PrintControl = 10
End If
.Cells(RowCount, 2) = FamilyName
.Cells(RowCount, 3) = MajMinArray(x, 2)
.Cells(RowCount, 4) = LaborCode
.Cells(RowCount, 5) = PrintControl
.Cells(RowCount, 6) = "1"
.Cells(RowCount, 7) = MajMinArray(x, 1)
RowCount = RowCount + 1
PrintControl = PrintControl + 10
LastFormType = MajMinArray(x, 2)
End If
Next
End With
End Sub
If restructuring the order of the data on the new sheet is possible it seems as though you could copy only visible cells and then write a simple loop to bring in any data that is not explicit (ie Labor Code).