Ik heb een Excel bestand met namen, postcodes en plaatsnamen. Ik wil filteren op een flink aantal postcodes uit een gebied. Wanneer die postcodes gevonden zijn, moeten de overige rijen worden verwijderd. Ik gebruikte daarvoor een macro.
Sinds kort is er een nieuwe opmaak en werkt de macro niet meer. Het duurt heel lang en uiteindelijk een foutmelding op Range("H1:H" & LastRowColA).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Wie weet de oplossing? Het Excel bestand is bijgevoegd.
Tekst van de macro:
Sinds kort is er een nieuwe opmaak en werkt de macro niet meer. Het duurt heel lang en uiteindelijk een foutmelding op Range("H1:H" & LastRowColA).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Wie weet de oplossing? Het Excel bestand is bijgevoegd.
Tekst van de macro:
Code:
Sub Alleen_KEN()
'Array met alle postcodes
Dim Postcodelijst(120)
Postcodelijst(1) = "1117"
Postcodelijst(2) = "1118"
Postcodelijst(3) = "1119"
Postcodelijst(4) = "1160"
Postcodelijst(5) = "1161"
Postcodelijst(6) = "1165"
Postcodelijst(7) = "1170"
Postcodelijst(8) = "1171"
Postcodelijst(9) = "1175"
Postcodelijst(10) = "1435"
Postcodelijst(11) = "1436"
Postcodelijst(12) = "1437"
Postcodelijst(13) = "1438"
Postcodelijst(14) = "1910"
Postcodelijst(15) = "1911"
Postcodelijst(16) = "1940"
Postcodelijst(17) = "1941"
Postcodelijst(18) = "1942"
Postcodelijst(19) = "1943"
Postcodelijst(20) = "1944"
Postcodelijst(21) = "1945"
Postcodelijst(22) = "1946"
Postcodelijst(23) = "1947"
Postcodelijst(24) = "1948"
Postcodelijst(25) = "1949"
Postcodelijst(26) = "1950"
Postcodelijst(27) = "1951"
Postcodelijst(28) = "1960"
Postcodelijst(29) = "1961"
Postcodelijst(30) = "1962"
Postcodelijst(31) = "1963"
Postcodelijst(32) = "1964"
Postcodelijst(33) = "1965"
Postcodelijst(34) = "1966"
Postcodelijst(35) = "1967"
Postcodelijst(36) = "1968"
Postcodelijst(37) = "1970"
Postcodelijst(38) = "1971"
Postcodelijst(39) = "1972"
Postcodelijst(40) = "1973"
Postcodelijst(41) = "1974"
Postcodelijst(42) = "1975"
Postcodelijst(43) = "1980"
Postcodelijst(44) = "1981"
Postcodelijst(45) = "1985"
Postcodelijst(46) = "1990"
Postcodelijst(47) = "1991"
Postcodelijst(48) = "1992"
Postcodelijst(49) = "2000"
Postcodelijst(50) = "2001"
Postcodelijst(51) = "2002"
Postcodelijst(52) = "2003"
Postcodelijst(53) = "2011"
Postcodelijst(54) = "2012"
Postcodelijst(55) = "2013"
Postcodelijst(56) = "2014"
Postcodelijst(57) = "2015"
Postcodelijst(58) = "2019"
Postcodelijst(59) = "2021"
Postcodelijst(60) = "2022"
Postcodelijst(61) = "2023"
Postcodelijst(62) = "2024"
Postcodelijst(63) = "2025"
Postcodelijst(64) = "2026"
Postcodelijst(65) = "2031"
Postcodelijst(66) = "2032"
Postcodelijst(67) = "2033"
Postcodelijst(68) = "2034"
Postcodelijst(69) = "2035"
Postcodelijst(70) = "2036"
Postcodelijst(71) = "2037"
Postcodelijst(72) = "2040"
Postcodelijst(73) = "2041"
Postcodelijst(74) = "2042"
Postcodelijst(75) = "2050"
Postcodelijst(76) = "2051"
Postcodelijst(77) = "2060"
Postcodelijst(78) = "2061"
Postcodelijst(79) = "2063"
Postcodelijst(80) = "2064"
Postcodelijst(81) = "2065"
Postcodelijst(82) = "2070"
Postcodelijst(83) = "2071"
Postcodelijst(84) = "2080"
Postcodelijst(85) = "2082"
Postcodelijst(86) = "2100"
Postcodelijst(87) = "2101"
Postcodelijst(88) = "2102"
Postcodelijst(89) = "2103"
Postcodelijst(90) = "2104"
Postcodelijst(91) = "2105"
Postcodelijst(92) = "2106"
Postcodelijst(93) = "2110"
Postcodelijst(94) = "2111"
Postcodelijst(95) = "2114"
Postcodelijst(96) = "2116"
Postcodelijst(97) = "2120"
Postcodelijst(98) = "2121"
Postcodelijst(99) = "2130"
Postcodelijst(100) = "2131"
Postcodelijst(101) = "2132"
Postcodelijst(102) = "2133"
Postcodelijst(103) = "2134"
Postcodelijst(104) = "2135"
Postcodelijst(105) = "2136"
Postcodelijst(106) = "2140"
Postcodelijst(107) = "2141"
Postcodelijst(108) = "2142"
Postcodelijst(109) = "2143"
Postcodelijst(110) = "2144"
Postcodelijst(111) = "2150"
Postcodelijst(112) = "2151"
Postcodelijst(113) = "2152"
Postcodelijst(114) = "2153"
Postcodelijst(115) = "2154"
Postcodelijst(116) = "2155"
Postcodelijst(117) = "2156"
Postcodelijst(118) = "2157"
Postcodelijst(119) = "2158"
Postcodelijst(120) = "2165"
Begin = 0
'Vinden of er een postcode in het bestand zit
For x = 1 To 20
For y = 1 To 20
If Cells(x, y) = "Naam" Then
Begin = x + 1
End If
If Cells(x, y) = "Achternaam" Then
Begin = x + 1
End If
'Zoeken naar type waarbij de eerste 4 karakters van een cel numeriek zijn en karakter 5-6 niet numeriek (i.e. 1999XX)
If (IsNumeric(Mid(Cells(x, y), 1, 4)) = True And IsNumeric(Mid(Cells(x, y), 5, 2)) = False And Len(Mid(Cells(x, y), 5, 2)) = 2) Then
PostcodenrBegin = 1
Postcodenrlengte = 4
Postcodecolom = y
Postcoderij = x
GoTo Endloop
End If
'Zoeken naar type waarbij de eerste 4 karakters van een cel numeriek zijn en karakter 6-7 niet numeriek (i.e. 1999 XX)
If (IsNumeric(Mid(Cells(x, y), 1, 4)) = True And IsNumeric(Mid(Cells(x, y), 5, 2)) = False And Len(Mid(Cells(x, y), 6, 2)) = 2) Then
PostcodenrBegin = 1
Postcodenrlengte = 4
Postcodecolom = y
Postcoderij = x
GoTo Endloop
End If
'Zoeken naar type waarbij de eerste 4 karakters van een cel numeriek zijn en karakter 5-6 niet numeriek (i.e. 1999) EN de cell ernaast bijv XX is.
If (IsNumeric(Mid(Cells(x, y), 1, 4)) = True And Len(Cells(x, y)) = 4 And Len(Cells(x, y + 1)) = 2 And IsNumeric(Cells(x, y + 1) = False)) Then
PostcodenrBegin = 1
Postcodenrlengte = 4
Postcodecolom = y
Postcoderij = x
GoTo Endloop
End If
Next y
Next x
If (PostcodenrBegin = "" Or Postcodenrlengte = "" Or Postcodecolom = "") Then
MsgBox "Kan geen postcode vinden"
Exit Sub
End If
Endloop:
If (PostcodenrBegin > 0 And Postcodenrlengte > 0 And Postcodecolom > 0) Then
Dim Postcode As Variant
LastRowColA = Range("H65536").End(xlUp).Row
If Begin = 0 Then
End
End If
For x = Begin To LastRowColA
For Each Postcode In Postcodelijst
If Postcode = Mid(Cells(x, Postcodecolom), PostcodenrBegin, Postcodenrlengte) Then
Postcodelocatie = "Alkmaar"
Exit For
Else
Postcodelocatie = "NietInAlkmaar"
End If
Next
If Postcodelocatie = "NietInAlkmaar" Then
Blaat = Cells(x, Postcodecolom).EntireRow.Value
Cells(x, Postcodecolom).EntireRow.Value = ""
End If
Next x
Range("H1:H" & LastRowColA).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Bijlagen
Laatst bewerkt: