Related
I am trying to work through a code that utilizes a system to check two different worksheets by using a for loop and highlight the differences/edits made in the second sheet ("Version 2") onto the first sheet ("Original"). I have a feeling that I need to utilize an array but I'm not advanced enough where I know how to store the values and then later write them onto another sheet (down below).
I've gotten the code so that it highlights all the relevant cells, but now I'm trying to output it into a report (on another sheet called 'Logged Changes') which will summarize all the cell addresses where edits were made. Please forgive all the variables as this is from an old code set where variables are not explicitly defined:
Private Sub CompareBasic()
Dim actSheet As Range
Dim k As Integer
Dim o As Long
Dim p As Long
Dim i As Integer
Dim change As Integer
o = Worksheets("Original").Cells(2, Columns.Count).End(xlToLeft).Column
p = Worksheets("Original").Range("A" & Rows.Count).End(xlUp).Row
change = 0
Sheets("Original").Select
For i = 2 To p
For k = 1 To o
If IsNumeric(Worksheets("Original").Cells(i, k).Value) = True Then
If Worksheets("Original").Cells(i, k).Value <> Worksheets("Version 2").Cells(i, k).Value Then
Worksheets("Original").Cells(i, k).Interior.ColorIndex = 37
change = change + 1
End If
Else
If StrComp(Worksheets("Original").Cells(i, k), Worksheets("Version 2").Cells(i, k), vbBinaryCompare) <> 0 Then
Worksheets("Original").Cells(i, k).Interior.ColorIndex = 37
change = change + 1
End If
End If
Next k
Next i
Unload Me
MsgBox "Number of cells edited counted: " & change, vbOKOnly + vbExclamation, "Summary"
b = Empty
answer = MsgBox("Do you want to run the Report?", vbYesNo + vbQuestion)
If answer = vbYes Then
If Sheet_Exists("Logged Changes") = False Then
Sheet_Name = "Logged Changes"
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = Sheet_Name
End If
Worksheets("Logged Changes").Range("A1") = "Edited Requirements"
Else
Unload Me
End If
End Sub
I have tried fiddling around with the code, but didn't want to clog it up with any unnecessary/broken lines. Any help would be greatly appreciated!
Try this:
Option Explicit
Private Sub CompareBasic()
Const SHT_REPORT As String = "Logged Changes"
Dim actSheet As Range
Dim c As Integer
Dim o As Long
Dim p As Long
Dim r As Long
Dim change As Long, wsOrig As Worksheet, wsNew As Worksheet, wsReport As Worksheet
Dim dataOrig, dataNew, rngData As Range, v1, v2, bDiff As Boolean
Dim arrUpdates
Set wsOrig = Worksheets("Original")
Set wsNew = Worksheets("Version 2")
o = wsOrig.Cells(2, Columns.Count).End(xlToLeft).Column
p = wsOrig.Range("A" & Rows.Count).End(xlUp).Row
Set rngData = wsOrig.Range("A2", wsOrig.Cells(p, o))
dataOrig = rngData.Value 'get an array of data
dataNew = wsNew.Range(rngData.Address).Value 'array of new data
ReDim arrUpdates(1 To rngData.Cells.Count, 1 To 3) 'for change info
change = 0
For r = 1 To UBound(dataOrig, 1)
For c = 1 To UBound(dataOrig, 2)
v1 = dataOrig(r, c)
v2 = dataNew(r, c)
If Len(v1) > 0 Or Len(v2) > 0 Then
If IsNumeric(v1) Then
bDiff = v1 <> v2
Else
bDiff = StrComp(v1, v2, vbBinaryCompare) <> 0
End If
End If
'any difference?
If bDiff Then
change = change + 1
With rngData.Cells(r, c)
arrUpdates(change, 1) = .Address
.Interior.ColorIndex = 37
End With
arrUpdates(change, 2) = v1
arrUpdates(change, 3) = v2
End If
Next c
Next r
If MsgBox("Do you want to run the Report?", vbYesNo + vbQuestion) = vbYes Then
With GetSheet(SHT_REPORT, ThisWorkbook)
.UsedRange.ClearContents
.Range("A1") = "Edited Requirements"
.Range("A3").Resize(1, 3).Value = Array("Address", wsOrig.Name, wsNew.Name)
.Range("A4").Resize(change, 3).Value = arrUpdates
End With
Else
'Unload Me
End If
End Sub
'return as sheet from wb by name (and create it if it doesn't exist)
Function GetSheet(wsName, wb As Workbook) As Worksheet
Dim rv As Worksheet
On Error Resume Next
Set rv = wb.Worksheets(wsName)
On Error GoTo 0
If rv Is Nothing Then
Set rv = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
rv.Name = "Logged Changes"
End If
Set GetSheet = rv
End Function
Sheet Differences
Option Explicit
Sub logChanges()
Const ws1Name As String = "Original"
Const ws2Name As String = "Version 2"
Const wsResult As String = "Logged Changes"
Const FirstRow As Long = 2
Const FirstColumn As Long = 1
Const LastRowColumn As Long = 1
Const LastColumnRow As Long = 2
Const ResultFirstCell As String = "A2"
Dim Headers As Variant
Headers = Array("Id", "Address", "Original", "Version 2")
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(ws1Name)
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, LastRowColumn).End(xlUp).Row
Dim LastColumn As Long
LastColumn = ws.Cells(LastColumnRow, ws.Columns.Count) _
.End(xlToLeft).Column
Dim rng As Range
Set rng = ws.Range(ws.Cells(FirstRow, FirstColumn), _
ws.Cells(LastRow, LastColumn))
Dim Data1 As Variant: Data1 = rng.Value
Set ws = wb.Worksheets(ws2Name)
Dim Data2 As Variant: Data2 = ws.Range(rng.Address).Value
Dim Result() As Variant
Dim i As Long, j As Long, k As Long
For i = 1 To UBound(Data1)
For j = 1 To UBound(Data1, 2)
If Data1(i, j) <> Data2(i, j) Then GoSub writeResult
Next j
Next i
If k > 0 Then
transpose2D Result
On Error GoTo MissingResultSheet
Set ws = wb.Worksheets(wsResult)
On Error GoTo 0
ws.Range(ws.Range(ResultFirstCell), _
ws.Cells(ws.Rows.Count, ws.Columns.Count)).Clear
ws.Range(ResultFirstCell).Resize(k, UBound(Result, 2)).Value = Result
MsgBox "Found '" & k & "' difference(s) in range '" _
& rng.Address(False, False) & "'.", vbInformation
Else
MsgBox "Found no differences in range '" _
& rng.Address(False, False) & "'.", vbExclamation
End If
Exit Sub
writeResult:
k = k + 1
ReDim Preserve Result(1 To 4, 1 To k)
Result(1, k) = k
Result(2, k) = getAddress(i + FirstRow - 1, j + FirstColumn - 1)
Result(3, k) = Data1(i, j)
Result(4, k) = Data2(i, j)
Return
MissingResultSheet:
If Err.Number = 9 Then
wb.Worksheets.Add After:=wb.Sheets(wb.Sheets.Count)
With ActiveSheet
.Name = wsResult
If .Range(ResultFirstCell).Row > 1 Then
.Range(ResultFirstCell).Offset(-1) _
.Resize(, UBound(Headers) + 1).Value = Headers
End If
End With
Resume ' i.e. the code continues with Set ws = wb.Worksheets(wsResult)
Else
'?
Exit Sub
End If
End Sub
Function getAddress(aRow As Long, aColumn As Long) As String
getAddress = ActiveSheet.Cells(aRow, aColumn).Address(False, False)
End Function
Sub transpose2D(ByRef Data As Variant)
Dim i As Long, j As Long
Dim Result As Variant
ReDim Result(LBound(Data, 2) To UBound(Data, 2), _
LBound(Data) To UBound(Data))
For i = LBound(Data) To UBound(Data)
For j = LBound(Data, 2) To UBound(Data, 2)
Result(j, i) = Data(i, j)
Next j
Next i
Data = Result
End Sub
This solution for converting a column number to a string without using objects Function to convert column number to letter? could be used to write a descent getAddress function.
I would like to rename worksheets in an exiting workbook. This is the code i am using:
Dim LobArray As Variant
Dim TypeArray As Variant
Dim g As String
'Added during Edit of question.
Dim NoLobs As Long, NoTypes As Long
Dim l As Long, t As Long, s As Long
Dim SheetNames(100) As String
Dim SheetCountSpL As Long
Dim TmplSpl As Workbook
Set TmplSpl = ThisWorkbook
'-----------------------------
g = "_"
LobArray = Array("Lob1", "Lob2", "Lob3", "Lob4")
TypeArray = Array("ea", "pa", "inc")
NoLobs = UBound(LobArray) - LBound(LobArray) + 1
NoTypes = UBound(TypeArray) - LBound(TypeArray) + 1
For l = LBound(LobArray) To UBound(LobArray)
For t = LBound(TypeArray) To UBound(TypeArray)
SheetNames(l * NoLobs + t) = LobArray(l) & g & TypeArray(t)
Next t
Next l
SheetCountSpL = NoTypes * NoLobs
For s = 1 To SheetCountSpL
TmplSpL.Worksheets(s).Activate
TmplSpL.Worksheets(s).Name = SheetNames(s - 1)
Next s
When i reduce the elements in the LobArray to 3 it works. Basically, when the macro has to rename more then 9 sheets, i get the error i mentioned in the title.
This is the code I use to create and rename sheets. It creates sheets based on selected cells and renames the new sheets accordingly. If sheets exist it deletes them
Sub CreateSheetsFromAList()
Dim MyCell As Range
Dim MyRange As Range
Set MyRange = Selection
For Each MyCell In MyRange
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
On Error Resume Next
Sheets(Sheets.Count).Name = MyCell.Value 'renames the new worksheet
If Err.Number = 1004 Then
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
End If
On Error GoTo 0
Next MyCell
End Sub
This is the error:
LobArray = four elements.
TypeArray = three elements.
l = 0, NoLobs = 4, t = 0 on first loop.
First inner loop:
0 * 4 + 0 = 0 = SheetNames(0) = LobArray(0) & TypeArray(0) = "Lob1_ea"
Second inner loop:
0 * 4 + 1 = 1 = SheetNames(1) = .....
Third inner loop:
0 * 4 + 2 = 2 = SheetNames(2) = .....
Fourth inner loop:
Doesn't occur as TypeArray only has 3 elements.
SheetNames(3) is left blank as a result
This code will rename your sheets:
Public Sub Test()
Dim LobArray As Variant
Dim TypeArray As Variant
Dim lobItm As Variant, typeItm As Variant
Dim g As String, x As Long
Dim RequiredSheetCount As Long
g = "_"
LobArray = Array("Lob1", "Lob2", "Lob3", "Lob4")
TypeArray = Array("ea", "pa", "inc")
RequiredSheetCount = (UBound(LobArray) + 1) * (UBound(TypeArray) + 1)
If Worksheets.Count >= RequiredSheetCount Then
For Each lobItm In LobArray
For Each typeItm In TypeArray
x = x + 1
ThisWorkbook.Worksheets(x).Name = lobItm & g & typeItm
Next typeItm
Next lobItm
Else
MsgBox "The workbook needs at least " & RequiredSheetCount & " sheets to work properly."
End If
End Sub
I have been writing this code for a few weeks now and it used to work, it took 2 hours to compile through the 49 worksheets I am comparing but for some reason it now just says not responding. I really want to try switching to use arrays so that if I can get it to work again it will go a lot faster. However even after reading a lot of posts about arrays I can't come up with a way to do it, besides knowing that I need to use a multidimensional array and have a varied row size. Can anyone give any advise? Thanks in advance!
More information, the code looks at what is in column e and if something else in column e matches it takes the values in columns t thru x and places them in that rows t thru x. It also colors the rows e if their t thru x are empty, or makes it white again if it finds it colored when it shouldn't be.
Sub FindPart_FullWorkbooks()
'If searching multiple worksheets & workbooks
Dim PartNumber As String
Dim Found1 As Integer
Dim Found2 As Boolean
Dim Found3 As Boolean
Dim Found4 As Boolean
Dim Found5 As Boolean
Dim Found6 As Boolean
Dim Found7 As Boolean
Dim Found8 As Boolean
Dim Found9 As Boolean
Dim Found10 As Boolean
Dim Found11 As Boolean
Dim Found12 As Boolean
Dim EOS As String
Dim EOSL As String
Dim EOL As String
Dim Replace As String
Dim AddInfo As String
Dim n As Long
Dim m As Long
Dim LastRow As Long
Dim WS As Worksheet
Dim WS2 As Worksheet
Dim WB As Workbook
Dim WB2 As Workbook
For Each WB In Workbooks
For Each WS In WB.Worksheets
With WS
LastRow = .Range("A1").SpecialCells(xlCellTypeLastCell).Row
End With
For m = 1 To LastRow
PartNumber = WB.Sheets(WS.Name).Cells(m, 5).Value
EOS = WB.Sheets(WS.Name).Cells(m, 20).Value
EOSL = WB.Sheets(WS.Name).Cells(m, 21).Value
EOL = WB.Sheets(WS.Name).Cells(m, 22).Value
Replace = WB.Sheets(WS.Name).Cells(m, 23).Value
AddInfo = WB.Sheets(WS.Name).Cells(m, 24).Value
Found2 = IsEmpty(WB.Sheets(WS.Name).Cells(m, 5).Value)
Found4 = IsEmpty(WB.Sheets(WS.Name).Cells(m, 20).Value)
Found5 = IsEmpty(WB.Sheets(WS.Name).Cells(m, 21).Value)
Found6 = IsEmpty(WB.Sheets(WS.Name).Cells(m, 22).Value)
Found7 = IsEmpty(WB.Sheets(WS.Name).Cells(m, 23).Value)
Found8 = IsEmpty(WB.Sheets(WS.Name).Cells(m, 24).Value)
If Found2 = True Then
GoTo NextIndex
Else
For Each WB2 In Workbooks
For Each WS2 In WB2.Worksheets
For n = 1 To LastRow
Found1 = InStr(WB2.Sheets(WS2.Name).Cells(n, 5).Value, PartNumber)
Found3 = IsEmpty(WB2.Sheets(WS2.Name).Cells(n, 20).Value)
Found9 = IsEmpty(WB2.Sheets(WS2.Name).Cells(n, 21).Value)
Found10 = IsEmpty(WB2.Sheets(WS2.Name).Cells(n, 22).Value)
Found11 = IsEmpty(WB2.Sheets(WS2.Name).Cells(n, 23).Value)
Found12 = IsEmpty(WB2.Sheets(WS2.Name).Cells(n, 24).Value)
If Found3 = True And Found9 = True And Found10 = True And Found11 = True And Found12 = True Then
If Found1 = 1 Then
WB2.Sheets(WS2.Name).Cells(n, 20).Value = EOS
WB2.Sheets(WS2.Name).Cells(n, 21).Value = EOSL
WB2.Sheets(WS2.Name).Cells(n, 22).Value = EOL
WB2.Sheets(WS2.Name).Cells(n, 23).Value = Replace
WB2.Sheets(WS2.Name).Cells(n, 24).Value = AddInfo
End If
End If
Next n
If Found4 = True And Found5 = True And Found6 = True And Found7 = True And Found8 = True Then
WB.Sheets(WS.Name).Cells(m, 5).Interior.Color = RGB(255, 0, 255)
ElseIf WB.Sheets(WS.Name).Cells(m, 5).Interior.Color = RGB(255, 0, 255) Then
WB.Sheets(WS.Name).Cells(m, 5).Interior.Color = RGB(255, 255, 255)
End If
'MsgBox (WB2.Name & " " & WS2.Name)
Next WS2
Next WB2
End If
'MsgBox (m)
NextIndex:
Next m
'MsgBox (WB.Name & " " & WS.Name)
Next WS
Next WB
End Sub
This answer was meant for the Code Review site but that question is on hold, so I'll provide it here
From a performance perspective you managed to code the worst-case scenario - maximum amount of work needed to accomplish the task. You probably did it just to get it working, and I'm up-voting the question because you made the right decision to ask for help
To illustrate consider we have 10 files, with 3 sheets each, and each sheet containing 1,000 rows (parts). What your algorithm does is loop through each file, and for each file loop through each file again (!), each sheet, and each row:
Result: 10 files * 3 sheets * 1,000 rows = 30,000 searches - interractions with the range
There are other issues as well:
You overwrite all data several times, including overwriting valid data with empty strings
Searching for a part number is not precise because of the InStr()
Not to mention basic issues like a naming convention that makes the code very hard to read, and the GoTo statement which doesn't help either
The first step to improve performance is what you had in mind: convert to arrays, but even that can't cope very well with the massive amount of work because there is still a lot of file interaction (moving through them over and over again), so the next step is to optimize the logic
When converting to arrays, the main concept to understand is that an array has the same structure as the data on the sheet - you can imagine the sheet in memory using rows and columns, except that columns don't use letters, so if you copy the data to memory doing this: dataArray = Sheet1.UsedRange, you access it the same way:
Sheet1.UsedRange.Cells(1, 1) = A1
dataArray(1, 1) = A1
except arrays are exponentially faster. You don't need to worry about the 2 dimensions of the array, if that makes things complicated, because VBA generates the proper array in this simple assignment dataArray = Sheet1.UsedRange, where dataArray should be defined as a Variant
Then, the only extra step needed after all processing is completed is to copy the data back to the sheet with this statement Sheet1.UsedRange = dataArray
So the first version I made is the original (inefficient) logic, converted to arrays, just to demonstrate how it can be done
The second version is an improved algorithm that iterates over all files, only twice
Once to read all part numbers into a dictionary
2nd time to update all part numbers (missing the details in columns T through X), in all files
Results with my data (3 files, with 3 sheets each, and each sheet containing 1,000 rows):
- v1: Time: 4399.262 sec (1.22 hrs) - your version
- v2: Time: 770.797 sec (12.8 min) - your version converted to arrays
- v3: Time: 2.684 sec - optimized logic (arrays + dictionary)
Version 2 (arrays):
Public Sub FindPart_FullWorkbooks3() '-----------------------------------------------
Const FR = 2 'First row, after header
Dim wb1 As Workbook, wb2 As Workbook, ws1 As Worksheet, ws2 As Worksheet
Dim ur1 As Variant, ur2 As Variant, info1 As String,info2 As String, updt As Boolean
Dim lr1 As Long, lr2 As Long, lc1 As Long, lc2 As Long, samePart As Boolean
Dim m(1 To 6), i As Byte, cel As Range, yColor As Long, nColor As Long
Dim r1 As Long, c1 As Long, r2 As Long, c2 As Long, y As Range, n As Range
yColor = RGB(255, 255, 255)
nColor = RGB(255, 0, 0)
m(1) = 5
m(2) = 20
m(3) = 21
m(4) = 22
m(5) = 23
m(6) = 24
For Each wb1 In Workbooks
For Each ws1 In wb1.Worksheets
ur1 = ws1.UsedRange
lr1 = UBound(ur1, 1) 'last row
lc1 = UBound(ur1, 2) 'last col
If lc1 >= 24 Then
For r1 = FR To lr1
If Len(ur1(r1, m(1))) > 0 Then
info1 = ur1(r1, m(2)) & ur1(r1, m(3)) & ur1(r1, m(4))
info1 = info1 & ur1(r1, m(5)) & ur1(r1, m(6))
Set cel = ws1.Cells(r1, m(1))
If Len(info1) > 0 Then
For Each wb2 In Workbooks
For Each ws2 In wb2.Worksheets
ur2 = ws2.UsedRange
lr2 = UBound(ur2, 1)
lc2 = UBound(ur2, 2)
If lc2 >= 24 Then
For r2 = FR To lr2
info2 = ur2(r2, m(2)) & ur2(r2, m(3)) & ur2(r2, m(4))
info2 = info2 & ur2(r2, m(5)) & ur2(r2, m(6))
samePart = InStr(ur2(r2, m(1)), ur1(r1, m(1))) = 1
If (samePart And Len(info2) = 0) Then
For i = 1 To 6
ur2(r2, m(i)) = ur1(r1, m(i))
Next
updt = True
End If
Next
End If
If updt Then
ws2.UsedRange = ur2
updt = False
End If
Next
Next
If y Is Nothing Then Set y = cel Else Set y = Union(y, cel)
Else
If n Is Nothing Then Set n = cel Else Set n = Union(n, cel)
End If
End If
Next
If Not y Is Nothing Then
If y.Interior.Color = nColor Then y.Interior.Color = yColor
Set y = Nothing
End If
If Not n Is Nothing Then
n.Interior.Color = nColor
Set n = Nothing
End If
End If
Next
Next
End Sub
Version 3 (Arrays and Dictionary)
Public Function UpdateAllParts() As Long '------------------------------------------
Const FR = 2 'First row, after header
Const DELIM = "<*>"
Dim wb As Workbook, ws As Worksheet, ur As Variant, i As Byte, iter As Long
Dim lr As Long, lc As Long, m(1 To 6), inf As String, frst As Boolean
Dim yColor As Long, nColor As Long, y As Range, n As Range, d As Dictionary
Dim cel As Range, lenDelim As Long, vals As Variant, r As Long, c As Long
yColor = RGB(255, 255, 255): nColor = RGB(255, 0, 0): Set d = New Dictionary
m(1) = 5: m(2) = 20: m(3) = 21: m(4) = 22: m(5) = 23: m(6) = 24
lenDelim = Len(DELIM) * 4
For iter = 1 To 2
frst = iter = 1
For Each wb In Workbooks
For Each ws In wb.Worksheets
ur = ws.Range(ws.Cells(1), ws.Cells.SpecialCells(xlCellTypeLastCell))
lr = UBound(ur, 1): lc = UBound(ur, 2)
If lc >= 24 Then
For r = FR To lr
If Len(ur(r, m(1))) > 0 Then
If frst Then Set cel = ws.Cells(r, m(1))
inf = ur(r, m(2)) & DELIM & ur(r, m(3)) & DELIM & ur(r, m(4))
inf = inf & DELIM & ur(r, m(5)) & DELIM & ur(r, m(6))
If frst Then
If Len(inf) > lenDelim Then
d(ur(r, m(1))) = inf 'add all to dict
If cel.Interior.Color = nColor Then
If y Is Nothing Then Set y = cel Else Set y = Union(y, cel)
End If
Else
If n Is Nothing Then Set n = cel Else Set n = Union(n, cel)
End If
Else
If Len(inf) = lenDelim Then
If d.Exists(ur(r, m(1))) Then
vals = Split(d(ur(r, m(1))), DELIM)
For i = 0 To 4
ur(r, m(i + 2)) = vals(i)
Next
End If
End If
End If
End If
Next
If frst Then
If Not y Is Nothing Then
If y.Interior.Color = nColor Then y.Interior.Color = yColor
Set y = Nothing
End If
If Not n Is Nothing Then
n.Interior.Color = nColor
Set n = Nothing
End If
Else
ws.Range(ws.Cells(1), ws.Cells.SpecialCells(xlCellTypeLastCell)) = ur
End If
End If
Next
Next
Next
UpdateAllParts = d.Count
End Function
Test data:
Before - all files with missing data:
After - all files, v1 (yours) - notice the records outlined in blue - invalid data
After - all files, v2 - same issue as in v1, accentuated by the array implementation
After - all files, v3
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).
Noob question: I want to count the non empty elements of an array?
My attempt:
Dim Arr(1 To 15) As Double
'populating some of the elements of Arr
'...
Dim nonEmptyElements As Integer, i As Integer
nonEmptyElements = 0: i = 0
For i = LBound(Arr) To UBound(Arr)
If Not Arr(i) = "" Then
nonEmptyElements = nonEmptyElements + 1
End If
Next
With this program I get the error: Type mismatch on If statement.
If try to change the if condition to If Not IsEmpty(Arr(i)) Then and i get nonEmptyElements = 15 as a result.
Any suggestions on how to complete the code?
Dim Arr(0 To 15) As Double
Arr(6) = 1.2
Arr(3) = 7
Dim nonEmptyElements As Integer, i As Integer
nonEmptyElements = 0 : i = 0
For i = LBound(Arr) To UBound(Arr)
If Not Arr(i) = 0 Then
nonEmptyElements = nonEmptyElements + 1
End If
Next
A double value by default is 0.0, so check if:
Arr(i) = 0
Application.CountA(myarray)
CountA is a worksheet function for counting non-empty values.
Applies only to VBA6, does not work in VBA7.