VBA macro to extract postcodes

What on earth is a bit of programming language doing in a blog about schools?

Simple. I want the Council to send me the postcode data for school entries over the last few years. They (finally) agree that the data does have to be disclosed under the Freedom of Information Act, but it's too big a task to take the list their system generates, which is addresses and postcodes, and extract the postcodes.

So here is a macro that can be used in Word (any version), to delete everything but the postcodes.

Let me know if it works for you!

Sub Macro1()
'
' Find postcodes, and leave them alone!
'
'

Selection.Find.ClearFormatting
With Selection.Find
.Text = "<[A-Z]{1,2}[0-9]{1,2}[ ]{1,2}[0-9]{1}[A-Z]{2}>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute
Do While Selection.Find.Found
' For Word2003 and below, uncomment below, and comment the following
' NormalTemplate.BuildingBlockEntries.AppendToSpike Range:=Selection.Range
NormalTemplate.AutoTextEntries.AppendToSpike Range:=Selection.Range
Selection.Find.Execute
Loop
Selection.Find.ClearFormatting
With Selection.Find
.Text = "<[A-Z]{1,2}[0-9]{1}[A-Z]{1}[ ]{1,2}[0-9]{1}[A-Z]{2}>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute
Do While Selection.Find.Found
' For Word2003 and below, uncomment below, and comment the following
' NormalTemplate.BuildingBlockEntries.AppendToSpike Range:=Selection.Range
NormalTemplate.AutoTextEntries.AppendToSpike Range:=Selection.Range
Selection.Find.Execute
Loop
Selection.Find.ClearFormatting
With Selection.Find
.Text = "<[A-Z]{1,2}[0-9]{2,3}[A-Z]{2}>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute
Do While Selection.Find.Found
' For Word2003 and below, uncomment below, and comment the following
' NormalTemplate.BuildingBlockEntries.AppendToSpike Range:=Selection.Range
NormalTemplate.AutoTextEntries.AppendToSpike Range:=Selection.Range
Selection.Find.Execute
Loop
Selection.WholeStory
With NormalTemplate.BuildingBlockEntries("Spike")
.Insert Where:=Selection.Range, RichText:=True
.Delete
End With
'PL1A2NH
Selection.Find.ClearFormatting
With Selection.Find
.Text = "<[A-Z]{1,2}[0-9][A-Z][0-9][A-Z]{2}>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute
Do While Selection.Find.Found
' For Word2003 and below, uncomment below, and comment the following
' NormalTemplate.BuildingBlockEntries.AppendToSpike Range:=Selection.Range
NormalTemplate.AutoTextEntries.AppendToSpike Range:=Selection.Range
Selection.Find.Execute
Loop


End Sub