Macro verschillende waarden laten selecteren

[michiel1000]

Hallo allemaal,

Ik zit met het volgende probleem. Ik probeer een macro te maken die bepaalde cellen selecteert op het moment dat waarden in andere cellen gelijk zijn aan "x". De macro moet aan de volgende condities voldoen.

Als K58 is gelijk aan x selecteer dan a1:k54
Als K115 is gelijk aan x selecteer dan a55:k111
Als K172 is gelijk aan x selecteer dan a112:k168
Als K229 is gelijk aan x selecteer dan a169:k225
Als K286 is gelijk aan x selecteer dan a226:k282

Stel dat alleen K172 en K 286 gelijk zijn aan x, dan moet het resultaat van de macro zijn dat A112:k168 en A226:k282 geselecteerd zijn.

Alvast bedankt voor de hulp!

 

[cow18]

Sub selecteren()
  Dim c        As Range
  Set c = Range("A1000")                                   'ergens een cel die er zeker niet in thuishoort
  If Range("K59").Value = "x" Then Set c = Union(c, Range("a1:k54"))
  If Range("K115").Value = "x" Then Set c = Union(c, Range("a55:k111"))
  If Range("K172").Value = "x" Then Set c = Union(c, Range("a112:k168"))
  If Range("K229").Value = "x" Then Set c = Union(c, Range("a169:k225"))
  If Range("K286").Value = "x" Then Set c = Union(c, Range("a226:k282"))
  Set c = Intersect(c, Rows("1:999"))                      'nu die oorspronkelijke cel eruit gooien
  If Not c Is Nothing Then MsgBox c.Address
End Sub

selecteren moet je zoveel mogelijk achterwege laten. Je kan rechtstreeks op dat bereik werken

 

[michiel1000]

Allereerst bedankt voor de hulp, ik krijg echter niet helemaal voor elkaar wat ik wil.

De bedoeling is dat de selectie wordt opgeslagen als pdf, ik gebruik daarvoor nu de volgende code.

Sub selecteren()
Dim c As Range
Dim myDir As String
Dim mySaveNaam As String

myDir = "X:\Verkoop\Klantoverzichten\"
mySaveNaam = Range("V2").Value

Set c = Range("A1000") 'ergens een cel die er zeker niet in thuishoort
If Range("K59").Value = "x" Then Set c = Union(c, Range("a1:k54"))
If Range("K115").Value = "x" Then Set c = Union(c, Range("a55:k111"))
If Range("K172").Value = "x" Then Set c = Union(c, Range("a112:k168"))
If Range("K229").Value = "x" Then Set c = Union(c, Range("a169:k225"))
If Range("K286").Value = "x" Then Set c = Union(c, Range("a226:k282"))
Set c = Intersect(c, Rows("1:999")) 'nu die oorspronkelijke cel eruit gooien
c.ExportAsFixedFormat Type:=xlTypePDF, Filename:=myDir & mySaveNaam & ".pdf", Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
If Not c Is Nothing Then MsgBox c.Address
End Sub

Nu krijg ik de volgende foutmelding: Fout -2147024773 (8007007b) tijdens uitvoering: Het document is niet opgeslagen.

 

[cow18]

Sub Bereik2PDF()
  Dim c        As Range
  Dim myDir    As String
  Dim mySaveNaam As String

  myDir = "X:\Verkoop\Klantoverzichten\"
  mySaveNaam = Range("V2").Value

  Set c = Range("A1000")                                   'ergens een cel die er zeker niet in thuishoort
  If Range("K59").Value = "x" Then Set c = Union(c, Range("a1:k54"))
  If Range("K115").Value = "x" Then Set c = Union(c, Range("a55:k111"))
  If Range("K172").Value = "x" Then Set c = Union(c, Range("a112:k168"))
  If Range("K229").Value = "x" Then Set c = Union(c, Range("a169:k225"))
  If Range("K286").Value = "x" Then Set c = Union(c, Range("a226:k282"))
  Set c = Intersect(c, Rows("1:999"))                      'nu die oorspronkelijke cel eruit gooien
  If Not c Is Nothing Then
    MsgBox "je bereik is : " & c.Address
    c.Copy
    Sheets.Add
    ActiveSheet.Paste
    MsgBox "je PDF noemt : " & myDir & mySaveNaam & ".pdf"
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=myDir & mySaveNaam & ".pdf", Quality:= _
                                    xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
                                    OpenAfterPublish:=True
    Rem Application.DisplayAlerts = False                      'als je straks die hinderlijke melding niet wilt krijgen, neem dan die rem weg
    ActiveSheet.Delete
    Rem Application.DisplayAlerts = True
  Else
    MsgBox "er was geen deftig bereik"
  End If
End Sub

 

[michiel1000]

Beste Cow18, ik krijg nog steeds dezelfde foutmelding.

De foutopsporing geeft aan dat het in het volgende stuk zit:

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=myDir & mySaveNaam & ".pdf", Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True

 

[michiel1000]

Ik denk dat het in de celeigenschappen zat, ik weet niet exact wat ik heb gedaan maar nu werkt het.

Cow18 bedankt!