For what I can tell its working perfectly
Thank you again for your time and efforts I do appreciate it
This one include the TypeCodeLabel in column J on CompareData.
This macro assumes that PanelData and DeviceType are in the same workbook (which must be .xlsm or .xlsb). The macro is installed into that workbook.
I used the full PanelData and DeviceType sheets you sent me in your last posting of workbooks.
I did not do extensive testing, so let me know how it works.
As written, it assumes there will be no "skipped" NodeAddress's. In other words, if there is a NodeAddress #4, #'s 1, 2, and 3 must also exist (but if there are no Loops in the missing Nodes, only Zone MergedAddresses will be generated.
==============================================
Option Explicit
'column names/labels are defined here.
'they must match exactly the names on PanelData Worksheet
'include names for any added columns
' and also be the same on any sheet generated
' by this code
Public Const sNA As String = "NodeAddress"
Public Const sLS As String = "LoopSelection"
Public Const sDA As String = "DeviceAddress"
Public Const sDT As String = "DeviceType"
Public Const sDTS As String = "Device Types"
Public Const sDL As String = "DeviceLabel"
Public Const sEL As String = "ExtendedLabel"
Public Const sMA As String = "Merged Address"
Public Const sTID As String = "TypeID"
Public Const sTCL As String = "TypeCodeLabel"
Sub CreateCompareDataSheet()
'Do this on a CompareData Sheet
'Keep only columns C:H
'Remove lines with no valid Device Address; (or not as required)
'Add Merged Address Column
'Append the "missing" Merged Addresses
'Rearrange columns by horizontal sorting according to custom list
'Sort results by Merged Address
Dim wsCompareData As Worksheet
Dim wsPD As Worksheet, vPD As Variant 'Panel Data
Dim wsDT As Worksheet, vDT As Variant 'Device Type
Dim r As Range, rw As Range, rMissed As Range
Dim NAcol As Long 'NodeAddress column
Dim NAwscol As Long 'NodeAddress column on worksheet
Dim LScol As Long 'Loop Selection column
Dim LSwscol As Long 'Loop Selection column on worksheet
Dim DTcol As Long 'Device Type column
Dim sDTP As String 'Used to create Merged Address
Dim DAcol As Long 'Device Address column
Dim MAcol As Long 'Merged Address column
Dim collUsedMA As Collection 'Used Merged Address Collection
Dim collMissMA As Collection 'Missing Merged Addresses
Dim DTScol As Long 'Device Types column
Dim TIDcol As Long 'Type ID column
Dim TCLcol As Long 'Type Code Label column
Dim NumNodes As Long, NumLoops As Long
Dim NodeLoops() As Long
Dim aTemp() As Variant
Dim v As Variant
Dim i As Long, j As Long
Application.ScreenUpdating = False
Set wsPD = Worksheets("PanelData")
Set wsDT = Worksheets("DeviceType")
'Clear CompareData sheet if present; create if not
On Error Resume Next
Set wsCompareData = Worksheets("CompareData")
If Err.Number = 9 Then
Worksheets.Add
ActiveSheet.Name = "CompareData"
Set wsCompareData = Worksheets("CompareData")
End If
On Error GoTo 0
wsCompareData.Cells.Clear
'Read Panel Data into array
'Assuming zero(0) blanks in Col A
'Assume we will retain only cols C:K
'HOWEVER, IF COLUMN LOCATIONS MIGHT CHANGE, THIS PART SHOULD
' BE RE-WRITTEN TO ACCOUNT FOR THAT
With wsPD
vPD = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)) _
.Offset(columnoffset:=2).Resize(columnsize:=9)
End With
'Add columns for Merged Address, Device Types and TypeCodeLabel
ReDim Preserve vPD(1 To UBound(vPD, 1), 1 To UBound(vPD, 2) + 3)
MAcol = UBound(vPD, 2) - 2
DTScol = UBound(vPD, 2) - 1
TCLcol = UBound(vPD, 2)
vPD(1, MAcol) = sMA
vPD(1, DTScol) = sDTS
vPD(1, TCLcol) = sTCL
'Get column numbers for data to create Used MergedAddress
'Also column numbers for TypeID and TypeCodeLabel
ReDim aTemp(1 To UBound(vPD, 2))
For i = 1 To UBound(vPD, 2)
aTemp(i) = vPD(1, i)
Next i
With WorksheetFunction
NAcol = .Match(sNA, aTemp, 0)
LScol = .Match(sLS, aTemp, 0)
DTcol = .Match(sDT, aTemp, 0)
DAcol = .Match(sDA, aTemp, 0)
TIDcol = .Match(sTID, aTemp, 0)
TCLcol = .Match(sTCL, aTemp, 0)
NAwscol = .Match(sNA, wsPD.Rows(1), 0)
LSwscol = .Match(sLS, wsPD.Rows(1), 0)
NumLoops = .Max(wsPD.Columns(LSwscol))
NumNodes = .Max(wsPD.Columns(NAwscol))
End With
'Decode Type ID
'Matching arrays for doing lookup (should be faster than
' doing it via the worksheet
Dim aTID() As Long, aTCL() As String
With wsDT
aTemp = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
ReDim aTID(1 To UBound(aTemp, 1))
For i = 1 To UBound(aTemp, 1)
aTID(i) = aTemp(i, 1)
Next i
ReDim aTCL(1 To UBound(aTemp, 1))
aTemp = .Range("E2", .Cells(.Rows.Count, "E").End(xlUp))
For i = 1 To UBound(aTemp, 1)
aTCL(i) = aTemp(i, 1)
Next i
If UBound(aTCL) <> UBound(aTID) Then
MsgBox ("Not all Type ID's correspond to TypeCodeLabels on DeviceType worksheet")
Exit Sub
End If
End With
For i = 2 To UBound(vPD, 1)
If vPD(i, TIDcol) <> 0 Then _
vPD(i, TCLcol) = aTCL(WorksheetFunction.Match(vPD(i, TIDcol), aTID, 0))
'if no match between TCL and TID, will have runtime error here
Next i
'Create Merged Addresses
'Add Device Types Field
Set collUsedMA = New Collection
For i = 2 To UBound(vPD, 1)
Select Case vPD(i, DTcol)
Case Is = 1
sDTP = "D"
vPD(i, DTScol) = "Detector"
Case Is = 2
sDTP = "M"
vPD(i, DTScol) = "Monitor"
Case Is = 3
sDTP = "Z"
vPD(i, DTScol) = "Zone"
Case Else
sDTP = ""
End Select
If Not sDTP = "" Then
vPD(i, MAcol) = _
IIf(NumNodes > 1, "N" & Format(vPD(i, NAcol), "000"), "") & _
"L" & Format(vPD(i, LScol), "00") & _
sDTP & _
Format(vPD(i, DAcol), "000")
'Special Case for Z
vPD(i, MAcol) = Replace(vPD(i, MAcol), "L00Z", "Z")
On Error Resume Next
collUsedMA.Add Item:=vPD(i, MAcol), Key:=vPD(i, MAcol)
If Err.Number <> 0 Then
MsgBox ("Merged Address: " & vPD(i, MAcol) & _
"on Line " & i & " is a duplicate")
Exit Sub
End If
On Error GoTo 0
End If
Next i
'Develop collection of Missing Merged Addresses
Set collMissMA = New Collection
'Argument for GenLoops will be 2D array
'Dimension1 - Node
'Dimenstion2 - Loops in corresponding Node
ReDim NodeLoops(1 To NumNodes)
With wsPD
.AutoFilterMode = False
With Range(.Cells(1, 1), .Cells(.Rows.Count, LSwscol).End(xlUp))
For i = 1 To NumNodes
.AutoFilter Field:=NAwscol, Criteria1:=i
NodeLoops(i) = WorksheetFunction.Subtotal(4, .Columns(LSwscol))
Next i
End With
.AutoFilterMode = False
End With
v = GenLoops(NodeLoops)
On Error Resume Next
For i = LBound(v) To UBound(v)
collUsedMA.Add Item:=v(i), Key:=v(i)
If Err.Number = 0 Then
collMissMA.Add Item:=v(i), Key:=v(i)
End If
Err.Clear
Next i
On Error GoTo 0
'write array to CompareData sheet
'sort by Merged Addresses and delete lines with no MA's
'then sort horizontally by first row and custom sort
'set up custom order based on fields in row 1 of panel data
'verify labels are correct
'Column Headers for Compare and Summary Sheets
'Need to be in the desired order -- will be used as a Custom Sort Order List
'Need to match exactly the headers (but not the order)
' on the PanelData worksheet
Dim aCL(1 To 9) 'custom list array of Column Labels
aCL(1) = sNA
aCL(2) = sLS
aCL(3) = sDA
aCL(4) = sMA
aCL(5) = sDT
aCL(6) = sDTS
aCL(7) = sDL
aCL(8) = sEL
aCL(9) = sTCL
ReDim aTemp(1 To UBound(vPD, 2))
For i = 1 To UBound(vPD, 2)
aTemp(i) = vPD(1, i)
Next i
On Error Resume Next
For i = 1 To UBound(aCL)
j = WorksheetFunction.Match(aCL(i), aTemp, 0)
If Err.Number <> 0 Then
MsgBox (aCL(i) & " Not exact match in Panel Data Label row")
Exit Sub
End If
Next i
On Error GoTo 0
'Write data to CompareData sheet
With wsCompareData
Set r = .Range("B1").Resize(rowsize:=UBound(vPD, 1), columnsize:=UBound(vPD, 2))
r = vPD
'Add the Missing Merged Addresses to the correct column
'Also deconstruct to fill in the NA, LS, DA and DT columns
'Possible formats
' Znnn
' LnnXnnn
' NnnnLnnXnnn
Set rw = r.Rows(1)
With WorksheetFunction
MAcol = .Match(sMA, rw, 0)
LScol = .Match(sLS, rw, 0)
DAcol = .Match(sDA, rw, 0)
DTcol = .Match(sDT, rw, 0)
NAcol = .Match(sNA, rw, 0)
End With
ReDim aTemp(1 To collMissMA.Count, 1 To r.Columns.Count)
For i = 1 To collMissMA.Count
aTemp(i, MAcol) = collMissMA(i)
aTemp(i, DAcol) = Val(Right(collMissMA(i), 3))
Select Case Left(collMissMA(i), 1)
Case Is = "Z"
aTemp(i, NAcol) = 1
aTemp(i, LScol) = 0
aTemp(i, DTcol) = 3
Case Is = "L"
aTemp(i, NAcol) = 1
aTemp(i, LScol) = Val(Mid(collMissMA(i), 2, 2))
Select Case Mid(collMissMA(i), 4, 1)
Case Is = "D"
aTemp(i, DTcol) = 1
Case Is = "M"
aTemp(i, DTcol) = 2
End Select
Case Is = "N"
aTemp(i, NAcol) = Val(Mid(collMissMA(i), 2, 3))
Select Case Mid(collMissMA(i), 8, 1)
Case Is = "D"
aTemp(i, DTcol) = 1
aTemp(i, LScol) = Val(Mid(collMissMA(i), 6, 2))
Case Is = "M"
aTemp(i, DTcol) = 2
aTemp(i, LScol) = Val(Mid(collMissMA(i), 6, 2))
Case Else 'must be Z
aTemp(i, DTcol) = 3
aTemp(i, LScol) = 0
End Select
End Select
Next i
Set rMissed = .Cells(r.Row + r.Rows.Count, r.Column).Resize(rowsize:=UBound(aTemp, 1), columnsize:=UBound(aTemp, 2))
rMissed = aTemp
Set r = Union(r, rMissed)
'Sort by Merged Address and delete those with blank MA's
'if result of sort needs to have Zones last then will need to add a dummy column for sorting
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=r.Resize(rowsize:=r.Rows.Count - 1).Offset(rowoffset:=1).Columns(MAcol), _
SortOn:=xlSortOnValues, Order:=xlAscending
With .Sort
.SetRange r
.Header = xlYes
.Orientation = xlTopToBottom
.Apply
End With
Set r = Range(r(1, MAcol).End(xlDown).Offset(rowoffset:=1), r(.Cells.Rows.Count, MAcol))
r.EntireRow.Delete
'Blank the columns we don't need and delete them after the sort
On Error Resume Next
For Each r In rw.Cells
i = WorksheetFunction.Match(r.Text, aCL, 0)
If Err.Number = 1004 Then r.ClearContents
Next r
On Error GoTo 0
'Now sort horizontally to reorder the columns
Set r = .UsedRange
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=r.Rows(1), _
SortOn:=xlSortOnValues, Order:=xlAscending, _
CustomOrder:=Join(aCL, ",")
With .Sort
.SetRange r
.Header = xlYes
.Orientation = xlLeftToRight
.Apply
End With
'clean up by clearing sort fields
.Sort.SortFields.Clear
'Delete blank columns
Set rw = Range(r(1).End(xlToRight), r(1)(1, r.Rows(1).Cells.Count))
Set rw = rw.Offset(columnoffset:=1).Resize(columnsize:=rw.Columns.Count - 1)
rw.EntireColumn.Delete
r.EntireColumn.AutoFit
'NOTE: Cannot use RGB on Macintosh. If that is a problem, use something
'like colorindex 15
r.Rows(1).Interior.Color = RGB(191, 191, 191) 'Same gray as on your Summary Sheet
'I don't like to activate or select, but I don't know how else to
' freeze panes
.Activate
With ActiveWindow
.SplitRow = 1
.FreezePanes = True
End With
.Range("a1").Select
End With
Application.ScreenUpdating = True
End Sub
'-------------------------------------------------------
Function GenLoops(NL) As Variant
'Part 0: N001-N104 (if more than one node)
'Part 1: L01-L10 (omit if part 2 is Z)
'Part 2: D or M or Z
'Part 3: 001-159 if part 2 is D|M; 0-999 if part 2 is Z
Dim MergAddr() As String
Dim NumLoops As Long, NumNodes As Long
Dim i As Long, j As Long, k As Long, l As Long, m As Long, n As Long
For i = 1 To UBound(NL)
j = j + NL(i) * 2 * 159 + 1000
Next i
ReDim MergAddr(1 To j) '+1000 for the zones
NumNodes = UBound(NL, 1)
For i = 1 To NumNodes
NumLoops = NL(i)
For j = 1 To NumLoops
For k = 1 To 2
For l = 1 To 159
m = m + 1
MergAddr(m) = _
IIf(NumNodes > 1, "N" & Format(i, "000"), "") & _
"L" & Format(j, "00") & _
IIf(k = 1, "D", "M") & _
Format(l, "000")
Next l
Next k
Next j
Next i
'add in the Zones Merged Addresses
j = UBound(MergAddr) - 1000 * UBound(NL)
For k = 1 To NumNodes
For i = 1 To 1000
MergAddr(j + i + (1000 * (k - 1))) = _
IIf(NumNodes > 1, "N" & Format(k, "000"), "") & _
"Z" & Format(i - 1, "000")
Next i
Next k
GenLoops = MergAddr
End Function
===================================
