Home |
Search |
Today's Posts |
#16
Posted to microsoft.public.excel.programming
|
|||
|
|||
leading zeros using ActiveCell.Offset().value to insert row and value
On Sun, 10 Feb 2013 19:43:27 +0000, TimLeonard wrote:
At this point I think the second workbook, as slow as it is and from piecing various codes together, works through all we have discussed except when adding missing addresses.. Here is a modified version that includes: Filling in the Loop Selection, Device Address and Device Type entries for the "missing" Merged Address Entries Formats the first row to have the gray interior and frozen header row as you do in some of your other examples. Includes some "clean-up" with regard to references. I could not fill in the NodeAddress column as I do not know how these are derived from the information I have. It runs in less than 1/2 second on my machine. It will not run as written on versions of Excel prior to 2007. If you might be running this on a Macintosh, you will need to change the interior color format to something that does not involve RGB. ================================ Option Explicit Sub CreateCompareDataSheet() 'Do this on a CompareData2 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 wsCompareData2 As Worksheet Dim wsPD As Worksheet, vPD As Variant 'Panel Data Dim r As Range, rw As Range, rMissed As Range Dim LScol As Long 'Loop Selection column Dim DTPcol As Long 'Device Type column Dim sDTP As String 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 DTPScol As Long 'Device Types column Dim aTemp() As Variant Dim v As Variant Dim i As Long, j As Long Set wsPD = Worksheets("PanelData") 'Clear CompareData2 sheet if present; create if not On Error Resume Next Set wsCompareData2 = Worksheets("CompareData2") If Err.Number = 9 Then Worksheets.Add ActiveSheet.Name = "CompareData2" Set wsCompareData2 = Worksheets("CompareData2") End If On Error GoTo 0 wsCompareData2.Cells.Clear 'Read Panel Data into array 'Assuming zero(0) blanks in Col A 'Assume we will retain only cols A:H With wsPD vPD = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)) _ .Offset(columnoffset:=2).Resize(columnsize:=6) End With 'Add column for merged address 'For now, it will be the "last column", but could be moved if desired ReDim Preserve vPD(1 To UBound(vPD, 1), 1 To UBound(vPD, 2) + 2) MAcol = UBound(vPD, 2) - 1 DTPScol = UBound(vPD, 2) vPD(1, MAcol) = "Merged Address" vPD(1, DTPScol) = "Device Types" 'Get column numbers for data to create MergedAddress ReDim aTemp(1 To UBound(vPD, 2)) For i = 1 To UBound(vPD, 2) aTemp(i) = vPD(1, i) Next i With WorksheetFunction LScol = .Match("LoopSelection", aTemp, 0) DTPcol = .Match("DeviceType", aTemp, 0) DAcol = .Match("DeviceAddress", aTemp, 0) End With 'Create Merged Addresses 'Add Device Types Field Set collUsedMA = New Collection For i = 2 To UBound(vPD, 1) Select Case vPD(i, DTPcol) Case Is = 1 sDTP = "D" vPD(i, DTPScol) = "Detector" Case Is = 2 sDTP = "M" vPD(i, DTPScol) = "Monitor" Case Is = 3 sDTP = "" vPD(i, DTPScol) = "Zone" Case Else sDTP = "" End Select If Not sDTP = "" Then vPD(i, MAcol) = "L" & Format(vPD(i, LScol), "00") & _ sDTP & _ Format(vPD(i, DAcol), "000") 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 With WorksheetFunction LScol = .Match("LoopSelection", wsPD.Rows(1), 0) v = GenLoops(.Max(wsPD.Columns(LScol))) End With 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 'write array to CompareData2 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 8) 'custom list array aCL(1) = "NodeAddress" aCL(2) = "LoopSelection" aCL(3) = "DeviceAddress" aCL(4) = "Merged Address" aCL(5) = "DeviceType" aCL(6) = "Device Types" aCL(7) = "DeviceLabel" aCL(8) = "ExtendedLabel" 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 'Write data to CompareData2 sheet Application.ScreenUpdating = False With wsCompareData2 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 LS, DA and DT columns Set rw = r.Rows(1) With WorksheetFunction MAcol = .Match("Merged Address", rw, 0) LScol = .Match("LoopSelection", rw, 0) DAcol = .Match("DeviceAddress", rw, 0) DTPcol = .Match("DeviceType", 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, LScol) = Val(Mid(collMissMA(i), 2, 2)) aTemp(i, DAcol) = Val(Right(collMissMA(i), 3)) aTemp(i, DTPcol) = IIf(Mid(collMissMA(i), 4, 1) = "D", 1, 2) 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 .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 '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 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 End With Application.ScreenUpdating = True End Sub '------------------------------------------------------- Function GenLoops(NumLoops) As Variant 'Part 1: L01-L10 'Part 2: D or M 'Part 3: 001-159 Dim MergAddr() As String Dim i As Long, j As Long, k As Long, m As Long ReDim MergAddr(1 To NumLoops * 2 * 159) For i = 1 To NumLoops For j = 1 To 2 For k = 1 To 159 m = m + 1 MergAddr(m) = "L" & Format(i, "00") & _ IIf(j = 1, "D", "M") & _ Format(k, "000") Next k Next j Next i GenLoops = MergAddr End Function ================================== |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Replace leading zeros with leading spaces ? | Excel Programming | |||
If activecell.column = variable then activecell,offset (0,1) | Excel Discussion (Misc queries) | |||
How do I insert leading zeros? | New Users to Excel | |||
save text field w/ leading zeros in .csv format & not lose zeros? | Excel Discussion (Misc queries) | |||
Insert Leading Zeros | Excel Worksheet Functions |