Snippets
Created by
SeanB
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 | 'Add to your person XLSB
'From there, you can add it to a toolbar
Sub SortOnPostCode()
Dim CWS As Worksheet
Dim region As Range
Dim Cell As Range
Dim ErrorText As String
Dim aStreetNo() As Variant
Dim iMaxRows As Integer
Dim iRow As Integer
Dim oddValue
Set CWS = ActiveSheet
Set region = Range("A1").CurrentRegion
iMaxRows = region.Rows.Count()
iMaxCol = region.Columns.Count()
For iCol = 1 To iMaxCol
region.Cells(1, iCol).Value = Trim(region.Cells(1, iCol).Value)
Next
'On Error GoTo ErrHandler
ErrorText = "Could not find the StreetNo Column"
'=================================
Set region = CWS.Rows(1)
Set region = region.Find("StreetNo")
Set region = region.Next
ErrorText = "Give new row a name"
region.EntireColumn.Insert
Set region = region.Previous
region.Rows(1) = "ISODD"
ErrorText = "Odds and Evens"
'=================================
Set region = CWS.Rows(1)
Set region = region.Find("StreetNo")
Set region = region.Resize(region.Rows.Count, region.Columns.Count + 1)
For iRow = 2 To iMaxRows
oddValue = region.Cells(iRow, 1)
If oddValue = "" Then
oddValue = 1
Else
oddValue = (oddValue Mod 2)
End If
region.Cells(iRow, 2) = oddValue
Next
ErrorText = "Remove 'The' from envelope Name"
'=================================
Set region = CWS.Rows(1)
Set region = region.Find("EnvName")
Set region = region.Next
region.EntireColumn.Insert
Set region = region.Previous
region.Rows(1) = "Salutation"
Set region = CWS.Rows(1)
Set region = region.Find("EnvName")
Set region = region.Resize(region.Rows.Count, region.Columns.Count + 1)
For iRow = 2 To iMaxRows
sFixedName = region.Cells(iRow, 1)
If (LCase(Left(sFixedName, 4))) = "the " Then
sFixedName = (Mid(sFixedName, 5))
End If
region.Cells(iRow, 2) = sFixedName
Next
ErrorText = "Sort by Ward, Walk, Street, ISODD and then StreetNo"
'=================================
'Ward, Walk, Street, ISODD and then StreetNo.
Set region = Range("A1").CurrentRegion
With CWS.Sort
.SortFields.Clear
.SortFields.Add Key:=FindKey("Ward"), Order:=xlAscending
.SortFields.Add Key:=FindKey("Walk"), Order:=xlAscending
.SortFields.Add Key:=FindKey("Street"), Order:=xlAscending
.SortFields.Add Key:=FindKey("ISODD"), Order:=xlAscending
.SortFields.Add Key:=FindKey("StreetNo"), Order:=xlAscending
.SetRange region
.Header = xlYes
.Apply
End With
ErrorText = "Add Sequence Number"
'=================================
Set region = Range("A1").EntireColumn
region.Insert
Set region = Range("A1").EntireColumn
region.Cells(1, 1) = "Seq"
For iRow = 2 To iMaxRows
sFixedName = region.Cells(iRow, 1)
region.Cells(iRow, 1) = (iRow - 1)
Next
ErrorText = "Delete Unneeded columns"
'=================================
RemoveColumn ("PollingDistrictCode")
RemoveColumn ("ElectorNumberWithSuffix")
RemoveColumn ("WalkManagerOrder")
RemoveColumn ("Building")
RemoveColumn ("StreetNo")
RemoveColumn ("ISODD")
RemoveColumn ("Street")
RemoveColumn ("AptNo")
RemoveColumn ("Phone")
RemoveColumn ("SubRoad")
RemoveColumn ("Locality")
RemoveColumn ("Westminster")
RemoveColumn ("County")
RemoveColumn ("CountyDivision")
RemoveColumn ("DevolvedRegion")
RemoveColumn ("DevolvedConstituency")
ErrorText = "Save file with correct ending"
'=================================
MsgBox saveFileForMerge()
ErrorText = "Close the file"
'=================================
ActiveWorkbook.Close
Exit Sub
ErrHandler:
MsgBox ErrorText
End Sub
Function FindKey(sKeyName)
Dim region As Range
Set CWS = ActiveSheet
Set region = CWS.Rows(1)
Set region = region.Find(What:=sKeyName, LookIn:=xlValues, LookAt:=xlWhole)
Set FindKey = region
End Function
Sub RemoveColumn(sKeyName)
Dim rg As Range
Set rg = FindKey(sKeyName)
If rg Is Nothing Then
Exit Sub
End If
Set rg = rg.EntireColumn
rg.Delete
End Sub
Function saveFileForMerge()
Dim WB As Workbook
Set WB = ActiveWorkbook
sFilename = WB.FullName
iPos = InStrRev(sFilename, ".")
If (iPos <> 0) Then
sFilename = Left(sFilename, iPos)
End If
sFilename = sFilename + "sdb"
WB.SaveAs Filename:=sFilename, FileFormat:=xlCSV
saveFileForMerge = sFilename
End Function
|
Comments (0)
You can clone a snippet to your computer for local editing. Learn more.