Keuzelijst via keuzelijst

[henkad]

Hallo,

Ik ben een kweeklijst voor vogels aan het maken en dit lukt aardig is al redelijk uitgebreid.
Maar waar ik tegenaan hik is dit:

Als ik in cel B1 een vogelsoort kies uit een keuzelijst dan moet er in een kolom bestaande uit die vogelsoort naam,
aan de rechterkant in een kolom al de kleuren van die soort weer als een keuzelijst naar voren komen in cel B2.

maar dan krijg ik een foutmelding dat er maar 1 rij of 1 kolom aangeven kan worden.
Het benoemen van die 2 kolommen als vogelkeuzelijst, heeft dan ook geen nut.
Iemand een idee hoe ik dit oplos? ik heb me al een paar dagen rot lopen zoeken en niets in die trend gevonden.
Bekijk bijlage gegevensvalidatielijstvoorbeeld.rar
met vriendelijke groet Henkad

 

[Warme bakkertje]

Kijk eens of je hier wat mee kan.

 

[henkad]

Jaaaa dit werkt,
hartelijk hartelijk dank warm bakkertje.
hier kan ik wat mee

groeten Henk.
p.s. thanks helpmij.nl voor het bemiddelen

 

[henkad]

inbouwen

hoi, alleen bij het inbouwen in de eigenlijk kaart is er een kink in de kabel het weigert.

vraag is nu hoe u het opgelost hebt, met een code - formule - macro?
ik zie niet veel, alleen namen lijst en bij validatie indirect meer niet?

groet henk

 

[Warme bakkertje]

Kan je de file met de kaart downloaden?
Zet je file op zoals in mijn voorbeeldbestand. Zorg ervoor dat in de namen geen spaties, trema's, komma's oid zitten. Geef nu voor elk bereik een naam die identiek is aan de kopnaam.
De lijst van kopnamen zet je dan in de eerste validatielijst. In de 2de validatielijst zet je dan als formule =Indirect(celverwijzing 1ste validatielijst)

 

[henkad]

Idd, ik had de namen vergeten toe te kennen.

Bedankt !! :thumb:

groeten Henk.:d

 

[henkad]

hoi,

ik krijg nu alleen dit nog niet voor elkaar:

If Sheets("ID").Range("M5").Value = Not "" Then
filenaam = Pad & Sheets("ID").Range("M5").Value & ".xls"
ActiveWorkbook.SaveAs Filename:=filenaam, FileFormat:=xlNormal, CreateBackup:=(Sheets("Kantoor").Range("N6").Value)
End If

als cel Sheets("ID").Range("M5") geen waarde heeft moet hij naar de volgende, deze code geeft geen fout, maar loopt gewoon door en slaat het als 0 bestand op en dat 24 keer.

iemand ervaring met vb code?

alvast bedankt.

 

[Warme bakkertje]

If Sheets("ID").Range("M5").Value <> "" Then
 filenaam = Pad & Sheets("ID").Range("M5").Value & ".xls"
 ActiveWorkbook.SaveAs Filename:=filenaam, FileFormat:=xlNormal, CreateBackup:=Sheets("Kantoor").Range("N6").Value
 End If

En wat bedoel je met "naar de volgende gaan" ?

 

[henkad]

Hallo Rudi;

En wat bedoel je met "naar de volgende gaan" ?

Als cel Sheets("ID").Range("M5") geen waarde heeft moet hij naar de volgende,
deze code geeft geen fout, maar loopt gewoon door en slaat het als 0 bestand op en dat 24 keer.

Dus dit stukje tekst moet voor 24 cellen gelden verwerken en opslaan.

Is de ene cel opgeslagen dan moet hij de volgende cel verwerken.

Maar bedankt voor je reactie, maar dat <> "" had ik al toegepast maar werkt ook niet. ik heb ook ~= geprobeerd maar werkt niet in vb blijkbaar.
Zie toegevoegd document, dit is totale macro om id per vogel op te slaan.

Mvg Henk

 

[Warme bakkertje]

Sub Personal_ID_Opslaan()
 
 'On Error Resume Next
 
 If Not exists Then
 MkDir Sheets("Kantoor").Range("c6").Value
 End If
 
 Application.DisplayAlerts = Sheets("Kantoor").Range("N5").Value
 Pad = Sheets("Kantoor").Range("c6").Value
 With Sheets("ID")
    For Each cl In .Range("M4:M27")
        If cl <> "" Then
            filenaam = Pad & cl.Value & ".xls"
            ActiveWorkbook.SaveAs Filename:=filenaam, FileFormat:=xlNormal, _
                CreateBackup:=(Sheets("Kantoor").Range("N6").Value)
        End If
    Next
End With
End Sub

 

[henkad]

Hallo;

Ook nu weer bedankt voor je reactie Rudi,
De code is een mooi stukje ingekort
alleen hij slaat ook nu weer lege cellen als 0 op.
ik ben er echter een stuk mee opgeschoten.

Grtn Henk

 

[henkad]

Ik ben alweer zover :

Sub Personal_ID_Opslaan()

 Pad = Sheets("Kantoor").Range("C6").Value
 With CreateObject("Scripting.FileSystemObject")
        If Not .FolderExists(Pad) Then .CreateFolder Pad
 End With

 Application.DisplayAlerts = Sheets("Kantoor").Range("N5").Value
 Pad = Sheets("Kantoor").Range("C6").Value
 With Sheets("ID")
    For Each cl In .Range("M4:M27")
        If cl <> "" Then
            filenaam = Pad & cl.Value & ".xls"
            ActiveWorkbook.SaveAs Filename:=filenaam, FileFormat:=xlNormal, _
                CreateBackup:=(Sheets("Kantoor").Range("N6").Value)
        End If
    Next
End With
End Sub

Die 'On Error Resume Next
veroorzaakte een foutmelding, want hij checkte of folder bestond, indien dit niet het geval was dan werd die aangemaakt.
Bestond hij echter wel, dan ging het mis vandaar dat stukje code er tussen (On Error Resume Next)
Maar op deze manier gaat het beter.
Nu alleen nog een oplossing voor dat if <> "" , ik struin het internet ervoor af.
Bedankt voor je hulp tot zover, je hebt me enorm geholpen.

Groeten Henk

p.s. Ik moet misschien er nog bij vermelden dat de range m4:m27, dat die cellen ieder uit samengestelde cellen bestaat.

 

[Warme bakkertje]

Zijn die cellen echt leeg, of staat er een formule in oid, want normaal gezien zou dit moeten werken als die cellen echt leeg zijn.

 

[henkad]

Hallo Rudi;

Er staan inderdaad formules in.

Onder anderen deze =(C4&" "&I2&" "&J2&" "&C2&" "&C28&" "&D28&" "&"en"&" "&G28&" "&H28)

grt Henk.

 

[henkad]

Opgelost

Hallo;

Ik ben er al uit. Na wat proberen kwam ik hier uit.

Iig bedankt voor de tips en oplossingen Rudi. :thumb:

Sub Personal_ID_Opslaan()

Pad = Sheets("Kantoor").Range("C6").Value
With CreateObject("Scripting.FileSystemObject")
If Not .FolderExists(Pad) Then .CreateFolder Pad
End With

Application.DisplayAlerts = Sheets("Kantoor").Range("N5").Value
Pad = Sheets("Kantoor").Range("C6").Value
With Sheets("ID")
For Each cl In .Range("M4:M27")
If cl >= "1" Then
filenaam = Pad & cl.Value & ".xls"
ActiveWorkbook.SaveAs Filename:=filenaam, FileFormat:=xlNormal, _
CreateBackup:=(Sheets("Kantoor").Range("N6").Value)
End If
Next
End With
End Sub



Mvg Henk.

 

[Warme bakkertje]

Er staan inderdaad formules in.

Ik las juist je laatste posts door en dat verandert wel heel wat nietwaar
Niet verwonderlijk dat het niet werkte, daarom dat een voorbeeldbestandje dat de situatie natuurgetrouw weergeeft soms van onschatbare waarde is.

 

[henkad]

Ja idd,

ik zat zo te denken en kon mij nog herinneren na het vele zoeken naar oplossingen,
dat het ook meetelde dat er formules in stonden. Vandaar dat ik het even melde.
Maar zoals ik al poste het is opgelost.

mvg Henk.

 

[snb]

Nog wel even stofzuigen:

Sub Personal_ID_Opslaan()
  c01=Sheets("Kantoor").Range("C6").Value

  if Dir(c01,16)="" then mkdir c01

  Application.DisplayAlerts = Sheets("Kantoor").Range("N5").Value

  For Each cl In Sheets("ID").Range("M4:M27")
     If cl >= "1" Then ActiveWorkbook.SaveAs c01 & cl.value & ".xls",CreateBackup:=Sheets("Kantoor").Range("N6").Value
  Next
End Sub

PS. Ik betwijfel de zin van 'application.dispayalerts.....'

 

[Warme bakkertje]

Daarom mijn opmerking, het had al 2 dagen geleden kunnen opgelost zijn

 

[henkad]

hoi hoi,

Maar ach het werkt toch, beter laat dan nooit

hartelijk dank voor het meedenken

groet henk.