Related
IS it possible to look for an array of strings and/or integers inside an array of strings and/or integers? If so, then how?
To find a string in an array of strings I use code like:
If IsInArray(LowerFilmWidthArray, LowerFilmWidth) then
'Dos tuff
end if
And a function is:
Function IsInArray(arr As Variant, myVal As Variant) As Boolean
IsInArray = Not IsError(Application.Match(myVal, arr, 0))
Debug.Print (IsInArray)
End Function
As a result example, imagine you have an array of integers (1-10) and You are looking if your array (1,5,6) are inside that previous array (all items of it) and then return True. In my case I am getting all my to look for values in columns from 3rd to last column with data, which would make up my array that I try to find ALL items of in another array and return true or false.
An actual example:
Dim LowerFilmWidthArray
LowerFilmWidthArray = Application.Transpose(Evaluate("row(320:420)"))
Dim LowerFilmWidth As Integer
LowerFilmWidth = Array(ThisWorkbook.Worksheets("Machine Specification").Cells(320, 400,400,620)
'I get theese from a range and they might as well be strings and an undefined number of defined by 3 to last column with data
if isinarray(LowerFilmWidthArray,LowerFilmWidth) then
msgbox("Great Success!")
end if
Result in this one would be false because of that last "620" which is not inside the LowerFilmWidthArray.
EDITED:
Still can't get this to work and my gut says that there's way too many unnecessary things in the answers when I simply need to take each item from an array and try to find it in another and get "TRUE" only if all items I was looking for are present in a big array.
I have converted my to look for array (smaller one) to get the values from a set range that will always be a row from 3 to lastcolumn.
Dim LowerFilmWidth
LowerFilmWidth = ThisWorkbook.Worksheets("Machine Specification").Range(Cells(Cells.Find("Lower Film Width (mm)").Row, 3), Cells(Cells.Find("Lower Film Width (mm)").Row, LastColumn))
And I expect this part to make an array of all the values in cells in that range. Now I need to see if all those items / elements are present in:
Dim LowerFilmWidthArray
LowerFilmWidthArray = Application.Transpose(Evaluate("row(320:420)"))
So I use the suggested function:
Function arrElemInArray(arr As Variant, arrX As Variant) As Boolean
Dim i As Long, j As Long, boolFound As Boolean
For i = LBound(arrX) To UBound(arrX)
For j = LBound(arr) To UBound(arr)
If CStr(arr(j)) = CStr(arrX(i)) Then
boolFound = True: Exit For
End If
If Not boolFound Then arrElemInArray = False: Exit Function
Next j
Next i
arrElemInArray = True
Debug.Print (arrElemInArray)
End Function
and engage it using
If arrElemInArray(LowerFilmWidthArray, LowerFilmWidth) Then
msgbox("Great success!")
End If
The solution has to work both with integers and strings. I still can't get it to work as expected. Often it returns "True" no matter what, but it seems that it only checks the first item in smaller array against the big array.
This code in the edit returns "subscript out of range" error on "CStr(arrX(i))".
But the values in the sheet are as in the image
The full subroutine looks like this:
Sub Testing()
Dim LastColumn As Long
LastColumn = Cells(Cells.Find("Parameters", lookat:=xlWhole).Row, Columns.Count).End(xlToLeft).Column
Dim LowerFilmWidth
LowerFilmWidth = ThisWorkbook.Worksheets("Machine Specification").Range(Cells(Cells.Find("Lower Film Width (mm)").Row, 3), Cells(Cells.Find("Lower Film Width (mm)").Row, LastColumn))
Dim LowerFilmWidthArray
LowerFilmWidthArray = Application.Transpose(Evaluate("row(320:420)"))
If arrElemInArray(LowerFilmWidthArray, LowerFilmWidth) Then
MsgBox ("Great success!")
End If
End Sub
Workbook:
enter link description here
Please, look at the next example. Is this what you try accomplishing?
Sub testArrInArr()
Dim arr(), arr1(), arr2(), arr3(), arr4()
arr1 = Array(1, 2, 3): arr2 = Array(2, 3, 4)
arr3 = Array(3, 6, 5, 4): arr4 = Array(4, 5, 6)
arr = Array(arr1, arr2, arr3)
Debug.Print arrIsInArray(arr, arr2)
End Sub
Function arrIsInArray(arr As Variant, arrX As Variant) As Boolean
Dim i As Long, jArr As String
For i = LBound(arr) To UBound(arr)
If Join(arr(i)) = Join(arrX) Then arrIsInArray = True: Exit Function
Next i
End Function
Edited:
In order to test each array element if exists in another array, plese try the next way:
Sub tst2CheckArrElements()
Dim arr, arr1, arr2
arr = Split("1,2,3,4,5", ","): arr1 = Split("Sausage,Dog,Ship", ","): arr2 = Split("1,3,2", ",")
Debug.Print arrElemInArray(arr, arr1)
Debug.Print arrElemInArray(arr, arr2)
End Sub
Function arrElemInArray(arr As Variant, arrX As Variant) As Boolean
Dim i As Long, j As Long, boolFound As Boolean, mtch
If Not IsArray(arrX) Then
For j = LBound(arr) To UBound(arr)
If CStr(arr(j)) = CStr(arrX) Then arrElemInArray = True: Exit For
Next j
Exit Function
End If
For i = LBound(arrX) To UBound(arrX, 2)
For j = LBound(arr) To UBound(arr)
If CStr(arr(j)) = CStr(arrX(1, i)) Then
boolFound = True: Exit For
End If
Next j
If Not boolFound Then arrElemInArray = False: Exit Function
boolFound = False
Next i
arrElemInArray = True
End Function
Is Array In Array
Personalized Study
Change the number format of the cells containing the values to general or to a numeric format to make it work.
Option Explicit
Sub Testing()
Const sHeader As String = "Parameters"
Const sProperty As String = "Lower Film Width (mm)"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Machine Specification")
' Reference the last cell of the used range.
Dim LastCell As Range
With ws.UsedRange
Set LastCell = .Cells(.Rows.Count, .Columns.Count)
Debug.Print "UsedRange: " & .Address(0, 0)
Debug.Print "LastCell: " & LastCell.Address(0, 0)
End With
' Reference the header cell.
Dim HeaderCell As Range
Set HeaderCell = ws.Cells.Find(sHeader, LastCell, xlFormulas, xlWhole)
If HeaderCell Is Nothing Then Exit Sub ' header not found
Debug.Print "HeaderCell: " & HeaderCell.Address(0, 0)
' Calculate the first column number.
Dim FirstColumn As Long: FirstColumn = HeaderCell.Column + 1
Debug.Print "FirstColumn: " & FirstColumn
' Calculate the last column number.
Dim LastColumn As Long: LastColumn = _
ws.Cells(HeaderCell.Row, ws.Columns.Count).End(xlToLeft).Column
If LastColumn < FirstColumn Then Exit Sub ' no data to the right of header
Debug.Print "LastColumn: " & LastColumn
' Reference the column range below the header cell
' to search for the property.
Dim sDataColumnRange As Range ' below the header
Set sDataColumnRange _
= HeaderCell.Resize(LastCell.Row - HeaderCell.Row).Offset(1)
Debug.Print "sDataColumnRange: " & sDataColumnRange.Address(0, 0); ""
' Reference the property cell.
Dim sPropertyCell As Range
With sDataColumnRange
Set sPropertyCell _
= .Find(sProperty, .Cells(.Rows.Count), xlFormulas, xlWhole)
If sPropertyCell Is Nothing Then Exit Sub ' property not found
Debug.Print "sPropertyCell: " & sPropertyCell.Address(0, 0)
End With
' Reference the property (values) row range (first to last column).
Dim PropertyRowRange As Range
Set PropertyRowRange = ws.Range(ws.Cells(sPropertyCell.Row, FirstColumn), _
ws.Cells(sPropertyCell.Row, LastColumn))
Debug.Print "PropertyRowRange: " & PropertyRowRange.Address(0, 0)
Debug.Print "PropertyRowRange Values" & vbLf & Join(Application.Transpose( _
Application.Transpose(PropertyRowRange.Value)), ", ")
' Populate the property values array.
Dim PropertyValuesArray As Variant
PropertyValuesArray = Application.Transpose(Evaluate("Row(320:420)"))
Debug.Print "PropertyValuesArray Values"
Debug.Print Join(PropertyValuesArray, ", ")
' Return the result whether all values of the property row range
' are found in the property values array.
If IsRowInArr(PropertyValuesArray, PropertyRowRange) Then
MsgBox "All matching.", vbInformation
Debug.Print "All matching."
Else
MsgBox "Not all matching.", vbCritical
Debug.Print "Not all matching."
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns a boolean indicating whether a 1D array ('InArr')
' contains all values in a row ('RowIndex')
' of a range ('IsRange').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function IsRowInArr( _
ByVal InArr As Variant, _
ByVal IsRange As Range, _
Optional ByVal RowIndex As Long = 1) _
As Boolean
Const ProcName As String = "IsRowInArr"
On Error GoTo ClearError
With IsRange.Rows(RowIndex)
Dim cCount As Long: cCount = .Columns.Count
If cCount = 1 Then
IsRowInArr = IsNumeric(Application.Match(.Value, InArr, 0))
Else
Dim IsRow As Variant: IsRow = .Value
IsRowInArr = Application.Count(Application.Match( _
IsRow, InArr, 0)) = cCount
End If
End With
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
Initial Answer
The function will return true if all the elements of an array (IsArr) are found in another array (InArr).
Option Explicit
Sub IsArrayInArrayTEST()
Dim InArr As Variant: InArr = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)
Dim IsArr As Variant
IsArr = Array(1)
Debug.Print IsArrayInArray(IsArr, InArr) ' True
IsArr = Array(1, 5, 11)
Debug.Print IsArrayInArray(IsArr, InArr) ' False
End Sub
Function IsArrayInArray( _
ByVal IsArr As Variant, _
ByVal InArr As Variant) _
As Boolean
Dim IsCount As Long: IsCount = UBound(IsArr) - LBound(IsArr) + 1
Dim rArr As Variant: rArr = Application.Match(IsArr, InArr, 0)
Dim rCount As Long: rCount = Application.Count(rArr)
'Debug.Print rCount, IsCount
If rCount = IsCount Then
IsArrayInArray = True
End If
End Function
As shown in the image, I want to first filter by column A for "Yes".
The above image shows after the filter and I want to save each unique "ID" in columns B and put them into an array called myArr. Ideally, myArr = [101, 5137, 97] and I would be able to call each value in the array using myArr(1), myArr(2), myArr(3)
Below is the code I had, but there are 2 problems:
my arr doesn't seem to be an actual array
it doesn't print the correct answers 101, 5137, 97. Instead, it only prints out 101, 5137
With [a1].CurrentRegion
.AutoFilter 1, "Yes"
'first create arr which include duplicated data
arr = .Offset(1, 1).Resize(.Rows.Count - 1, 1).SpecialCells(xlVisible)
'myArr is an array with unique values
myArr = Application.Unique(arr)
'print out each value of myArr to check if myArr is correct
For Each num In myArr
Debug.Print num
Next num
.AutoFilter
End With
Please give me some ideas on what's wrong with my code above.
Your code is failing because once you apply the filter, the range is no longer contiguous. Your method will only capture a contiguous range.
Because you are setting the Autofilter value from within your routine, lets just check the values inside of an array, and then add the correct values to a dictionary, which will only accept unique values anyways.
Public Sub testUniqueArray()
Dim arrTemp As Variant, key As Variant
Dim dict As Object
Dim i As Long
arrTemp = [a1].CurrentRegion.Value
Set dict = CreateObject("Scripting.Dictionary")
For i = LBound(arrTemp) To UBound(arrTemp)
If arrTemp(i, 1) = "Yes" Then
dict(arrTemp(i, 2)) = 1
End If
Next i
For Each key In dict.Keys
Debug.Print key
Next key
End Sub
Unique Values from Filtered Column to Array
Option Explicit
Sub PrintUniqueValues()
Const CriteriaColumn As Long = 1
Const ValueColumn As Long = 2
Const CriteriaString As String = "Yes"
Dim ws As Worksheet: Set ws = ActiveSheet
' You better improve e.g. by using the worksheet (tab) name...
'Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
'Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
' ... or by using the code name:
'Dim ws As Worksheet: Set ws = Sheet1
Application.ScreenUpdating = False
If ws.AutoFilterMode Then
ws.AutoFilterMode = False
End If
Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
rg.AutoFilter CriteriaColumn, CriteriaString
Dim Arr As Variant: Arr = ArrUniqueFromFilteredColumn(rg, ValueColumn)
ws.AutoFilterMode = False
Application.ScreenUpdating = True
If IsEmpty(Arr) Then Exit Sub
' Either (preferred when dealing with arrays)...
Dim n As Long
For n = LBound(Arr) To UBound(Arr)
Debug.Print Arr(n)
Next n
' ... or:
' Dim Item As Variant
' For Each Item In Arr
' Debug.Print Item
' Next Item
End Sub
Function ArrUniqueFromFilteredColumn( _
ByVal rg As Range, _
ByVal ValueColumn As Long) _
As Variant
If rg Is Nothing Then Exit Function
If ValueColumn < 1 Then Exit Function
If ValueColumn > rg.Columns.Count Then Exit Function
Dim crg As Range
Set crg = rg.Columns(ValueColumn).Resize(rg.Rows.Count - 1).Offset(1)
Dim CellsCount As Long
CellsCount = WorksheetFunction.Subtotal(103, crg) ' 103 - CountA
If CellsCount = 0 Then Exit Function ' no match or only empty cells
'Debug.Print "CellsCount = " & CellsCount
Dim scrg As Range: Set scrg = crg.SpecialCells(xlCellTypeVisible)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare ' ignore case
Dim cCell As Range
Dim Key As Variant
For Each cCell In scrg.Cells
Key = cCell.Value
If Not IsError(Key) Then
If Len(Key) > 0 Then
dict(Key) = Empty
' The previous line is a short version of:
'If Not dict.Exists(Key) Then dict.Add Key, Empty
End If
End If
Next cCell
If dict.Count = 0 Then Exit Function ' only errors and blanks
'Debug.Print "dict.Count = " & dict.Count
ArrUniqueFromFilteredColumn = dict.Keys
End Function
I've got a sub representing a commandbutton of my userform, this userform has the perpose of listing (in a listbox) all unique items found in a column of a two-dimensional array. At frst I would like to implant an extra variable to hold and thus represent the number of times the unique item appears in the array. Secondly I would like the (Unique) items listed as:
Unique item 1 (number of appearances).
Example 1 (23)
Example 2 (39)
Example 3 (101)
Example 4 (9)
...
Example n (#)
Here is the code, can some body help me out?
Private Sub CommandButton5_Click()
Dim ws As Worksheet
Dim dictUnq As Object
Dim UnqList() As String
Dim aData As Variant
Dim vData As Variant
Dim pData As Variant
Dim i As Variant
Dim PrintString1() As String
i = 1
Set ws = ActiveWorkbook.Sheets("Sheet3")
Set dictUnq = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Application.EnableEvents = False
With ws.Range("G2", ws.Cells(ws.Rows.Count, "G").End(xlUp))
If .Row < 2 Then Exit Sub 'No data
If .Cells.Count = 1 Then
ReDim aData(1 To 1, 1 To 1)
aData(1, 1) = .Value
Else
aData = .Value
End If
End With
SBI_Omschrijving.ListBox1.Clear
For Each vData In aData
If Len(vData) > 0 Then
If Not dictUnq.exists(vData) Then dictUnq.Add vData, vData
End If
Next vData
Debug.Print dictUnq(vData)
SBI_Omschrijving.ListBox1.List = dictUnq.keys
MsgBox "Unique findings: " & dictUnq.Count
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Use a dictionary to store the count? This demonstrates the principle. Note in your example I think you may only be adding one column G so I don't know of you intended more?
Sub test()
Dim myArray()
myArray = ActiveSheet.Range("A1").CurrentRegion.Value
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim i As Long
For i = LBound(myArray, 1) To UBound(myArray, 1) 'Depending on column of interest. Loop that
If Not dict.Exists(myArray(i, 1)) Then
dict.Add myArray(i, 1), 1
Else
dict(myArray(i, 1)) = dict(myArray(i, 1)) + 1
End If
Next i
Dim key As Variant
For Each key In dict.keys
Debug.Print key & "(" & dict(key) & ")"
Next key
End Sub
Your example might be something like (can't test dictionary on a mac I'm afraid so coding in my head)
Sub test()
Dim aData()
Dim ws As Worksheet
Dim targetRange As Range
Dim lastRow As Long
Set ws = ActiveSheet
lastRow = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
If lastRow = 1 Then Exit Sub
Set targetRange = ws.Range("G2:G" & lastRow)
If targetRange.Cells.Count = 1 Then
ReDim aData(1 To 1, 1 To 1)
aData(1, 1) = targetRange.Value
Else
aData = targetRange.Value2
End If
Dim dictUnq As Object
Set dictUnq = CreateObject("Scripting.Dictionary")
Dim i As Long
For i = LBound(aData, 1) To UBound(aData, 1) 'Depending on column of interest. Loop that
If Not dictUnq.Exists(aData(i, 1)) Then
dictUnq.Add aData(i, 1), 1
Else
dictUnq(aData(i, 1)) = dictUnq(aData(i, 1)) + 1
End If
Next i
Dim key As Variant
For Each key In dictUnq.keys
Debug.Print key & "(" & dictUnq(key) & ")"
Next key
End Sub
another possibility
Option Explicit
Private Sub CommandButton5_Click()
Dim dictUnq As Object
Set dictUnq = CreateObject("Scripting.Dictionary")
Dim cell As Range
With ActiveWorkbook.Sheets("Sheet3")
For Each cell In .Range("G2", .Cells(.Rows.Count, "G").End(xlUp))
dictUnq(cell.Value) = dictUnq(cell.Value) + 1
Next
End With
If dictUnq.Count = 0 Then Exit Sub
Dim key As Variant
With SBI_Omschrijving.ListBox1
.Clear
.ColumnCount = 2
For Each key In dictUnq.keys
.AddItem key
.List(.ListCount - 1, 1) = dictUnq(key)
Next
End With
MsgBox "Unique findings: " & dictUnq.Count
End Sub
Excel 2013 with vba:
I have 2 columns in Sheet1 Column A has NBA Players while Column B shows their Jersey Numbers. If I type 2 in txtNumber it will display Players with number 2 on their Jerseys. It works on that way, However I can't click or select the entry or data. I'm thinking that Listbox would be a better replacement for TextBox, however I just don't know how to use the listbox. Please help.
Screenshot
code:
Private Sub txtNumber_Change()
Dim mySheet As Worksheet 'declaring mySheet as the Worksheet...
Dim x
Dim i As Long
Dim str As String
Set mySheet = Sheets("Sheet1")
x = mySheet.Range("A1").CurrentRegion.Value
For i = 2 To UBound(x, 1)
If x(i, 2) = Val(txtNumber.Value) Then
If str = "" Then
str = x(i, 1)
Else
str = str & vbNewLine & x(i, 1)
End If
End If
Next i
If str <> "" Then
txtName.Value = str
Else
txtName.Value = "Match not found"
End If
End Sub
Assuming the name of the listbox is ListBox1 then you may try something like this...
Private Sub txtNumber_Change()
Dim mySheet As Worksheet 'declaring mySheet as the Worksheet...
Dim x, dict
Dim i As Long
Dim cnt As Long
Set mySheet = Sheets("Sheet1")
ListBox1.Clear
x = mySheet.Range("A1").CurrentRegion.Value
Set dict = CreateObject("Scripting.Dictionary")
If Application.CountIf(mySheet.Columns(2), txtNumber.Value) > 0 Then
For i = 2 To UBound(x, 1)
If x(i, 2) = Val(txtNumber.Value) Then
dict.Item(x(i, 1)) = ""
End If
Next i
ListBox1.List = dict.keys
Else
ListBox1.AddItem "Match not found"
End If
End Sub
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).