Auto fill bij muisklik (code vereenvoudigen?)

[Peteroo]

Beste Leden,

 

Ik heb een bestand waarbij ik bij meerdere ranges één bepaalde character wil plaatsen dmv een muisklik. Nu heb ik een code gevonden die met 1 muisklik elke cell binnen een range vult met een waarde uit Cel FI1. Tot +- 400 Ranges gaat het goed. Daarna krijg ik de melding: "Compileerfout: De procedure is te groot". Hieronder vindt je een klein stukje van mijn code. Kan iemand mij helpen dit script te vereenvoudigen?

 

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim R As Range
  '1
  Set R = Intersect(Target, [14:42], [C:BP])
  If Not R Is Nothing Then R = [FI1]
  Set R = Intersect(Target, [14:42], [BV:EI])
  If Not R Is Nothing Then R = [FI1]
  '2
  Set R = Intersect(Target, [95:123], [C:BP])
  If Not R Is Nothing Then R = [FI1]
  Set R = Intersect(Target, [95:123], [BV:EI])
  If Not R Is Nothing Then R = [FI1]
  '3
  Set R = Intersect(Target, [176:204], [C:BP])
  If Not R Is Nothing Then R = [FI1]
  Set R = Intersect(Target, [176:204], [BV:EI])
  If Not R Is Nothing Then R = [FI1]
  '4
  Set R = Intersect(Target, [257:285], [C:BP])
  If Not R Is Nothing Then R = [FI1]
  Set R = Intersect(Target, [257:285], [BV:EI])
  If Not R Is Nothing Then R = [FI1]
  '5
  Set R = Intersect(Target, [338:366], [C:BP])
  If Not R Is Nothing Then R = [FI1]
  Set R = Intersect(Target, [338:366], [BV:EI])
  If Not R Is Nothing Then R = [FI1]
  '6
  Set R = Intersect(Target, [419:447], [C:BP])
  If Not R Is Nothing Then R = [FI1]
  Set R = Intersect(Target, [419:447], [BV:EI])
  If Not R Is Nothing Then R = [FI1]
  '7
  Set R = Intersect(Target, [500:528], [C:BP])
  If Not R Is Nothing Then R = [FI1]
  Set R = Intersect(Target, [500:528], [BV:EI])
  If Not R Is Nothing Then R = [FI1]

 

[emielDS]

een voorbeeldbestandje kan wonderen doen.