Drop-down menu

[dartfreak1987]

Ik heb hem gisteren en vandaag zitten testen
Maar ik loop nu tegen en paar problemen aan
gisteren in de eerste versie waar die de opmaak niet mee deed overnemen werkte alles perfect
op de opmaak na dan

en 2de versie waar die de opmaak met cel grote en verborgen cellen mee doet overnemen niet
hij opent namelijk niet het juiste tabblad hij zit er 3 tot 5 naast
kan dit komen dat hij op tabblad nummer zoekt en niet op tabblad naam?
en het nieuwe tabblad krijgt niet de juiste naam die ik bij titel toernooi invoer
maar de naam van het originele tabblad uit de oorspronkelijke werkmap

tevens is mijn vraag of het mogelijk is om in de macro op te nemen dat hij kolom c doet kopieren naar kolom a op het nieuwe tabblad?

 

[HSV]

Het is een getal in cel I5, en dan is het juist dat het de opvolgende tabblad opende.
Maak daarvan:

.Sheets([COLOR=#ff0000]cstr([/COLOR]Wb.Range("I5").Value)[COLOR=#ff0000])[/COLOR].Copy

Kijk eerst maar eens of het nu wel klopt.

 

[dartfreak1987]

nu doet hij wel het juiste tabblad door zetten

alleen hij vraagt elke keer als hij het nieuwe tabblad opent of die in de originele iets moet opslaan
zit er iets fout?

tevens nog de vraag of het mogelijk is om kolom c te kopieren naar kolom a op het nieuwe tabblad?

 

[HSV]

Het eerste kan ik helaas niet reproduceren.
Wanneer of hoe komt die melding tot stand.

Sub hsv()
Dim Wb As Object, cp, sh As Shape, clr
Set Wb = ThisWorkbook.Sheets("inschrijving")
With GetObject("c:\users\hsv\desktop\" & Wb.Range("j19") & ".xls")
  .Sheets(CStr(Wb.Range("I5").Value)).Copy , ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    ActiveSheet.Name = Wb.Range("I5").Value
     With ThisWorkbook.Sheets(CStr(Wb.Range("I5").Value))
       clr = .Cells(1).Interior.Color
      .Columns(3).Cut .Columns(1)
      .Columns(3).Interior.Color = clr
    End With
 .Close
 End With
End Sub

 

[dartfreak1987]

dit komt tot stand als hij het nieuwe tabblad heeft geopend
dan vraagt hij
wilt u de wijzigingen in (werkmap naam) opslaan?
als u op niet klikt, is er tijdelijke een kopie van dit bestand beschikbaar

en bij sommige programma's vraagt hij:
de naam week bestaat al. klik op ja om deze versie van de naam te gebruiken of klik op nee om de naam van de versie van week te wijzigen die u verplaatst of kopieert

zodra ik op ja klik krijgt het tabblad wel de juiste naam


toevoeging
ik vind het gewoon raar

ik heb net de macro geprobeerd
maar hij knipt kolom c en plakt die in kolom a maar de bewerking doet die op 1 tabblad
dus kolom c van het nieuwe tabblad knipt hij naar kolom a in het nieuwe tabblad

en mijn bedoeling was dus dat die kolom c doet kopieren van het inschrijfblad en doet plakken in kolom a op het nieuwe tabblad

 

[HSV]

Je eerste vraag gaat over het bestand waar een tabblad uit is gekopieerd?
Zet een nul achter

.close 0

Je tweede vraag:
Een bladnaam kan geen twee keer voorkomen in een bestand.
Je zult dus iets unieks moeten bedenken of programmeren dat je geen twee dezelfde bladnamen importeert.

 

[dartfreak1987]

en over mijn toevoeging?

 

[HSV]

Die heb ik gemist.

Sub hsv()
Dim Wb As Object, cp, sh As Shape, clr
Set Wb = ThisWorkbook.Sheets("inschrijving")
With GetObject("c:\users\hsv\desktop\" & Wb.Range("j19") & ".xls")
  .Sheets(CStr(Wb.Range("I5").Value)).Copy , ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
      ActiveSheet.Name = Wb.Range("I5").Value
      Wb.Columns(3).Copy ThisWorkbook.Sheets(CStr(Wb.Range("I5").Value)).Columns(1)
   .Close 0
 End With
End Sub

 

[dartfreak1987]

in 1 woord ben je te omschrijven
GEWELDIG
dit werk perfect

er rest me nu alleen nog 1 vraag over de werkmap
hoe kan ik meerdere tabbladen inschrijvingen invoegen in de werkmap?
want kopiëren gaat niet namelijk
ik heb soms 4 toernooien tegelijk
en dan is het wel handig dat ik een aparte inschrijf pagina per toernooi heb

en 1 vraag over de schijf
ik heb het programma op een usb stick staan
de regel: With GetObject("c:\users\hsv\desktop" & Wb.Range("j19") & ".xls")
is die vast als die op een stick staat?
of wijzigd die als de stick een andere schijf letter krijgt?

 

[HSV]

Waarom is het niet mogelijk in je eerste vraag.
Begrijp ik niet.

2:
Je kunt het zo aanpassen als je zelf wilt.
schijfletter:\mapnaam\eventueel tweede mapnaam\+de rest.

 

[dartfreak1987]

Ik weet nu niet of ik het goed begrijp.
Maar wat ik bedoel is dat ik alles op een usb stick heb staan.
En die heeft op mijn laptop de letter F.
Maar als ik dezelfde stick insteek op me vaders pc dan krijgt hij bijvoorbeeld de letter G.
Maakt dit wat uit voor de macro?

En terug komend op mijn eerste vraag.
Zodra ik het tabblad kopieer (via rechter muisknop kopieren verplaatsten) in de zelfde werkmap dat geeft hij een fout melding
De foutmelding gaat over de naam van het nieuwe tabblad.
De rest werkt gewoon.

Is hier een oplossing voor?

 

[HSV]

Als er maar één USB stick aan de Pc hangt.

Sub hsv()
Dim Wb As Object, cp, sh As Shape[COLOR=#ff0000], dr, drletter[/COLOR]
[COLOR=#ff0000]Application.DisplayAlerts = False[/COLOR]
[COLOR=#ff0000]  On Error Resume Next[/COLOR]
[COLOR=#ff0000]   For Each dr In CreateObject("scripting.filesystemobject").drives[/COLOR]
[COLOR=#ff0000]     If dr.drivetype = 1 Then drletter = dr.driveletter[/COLOR]
[COLOR=#ff0000]  Next[/COLOR]


Set Wb = ThisWorkbook.Sheets("inschrijving")
[COLOR="#FF0000"]With GetObject(drletter & ":\" & Wb.Range("j19") & ".xls")[/COLOR]
  .Sheets(CStr(Wb.Range("I5").Value)).Copy , ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    ActiveSheet.Name = Wb.Range("I5").Value
    Wb.Columns(3).Copy ThisWorkbook.Sheets(CStr(Wb.Range("I5").Value)).Columns(1)
  .Close 0
 End With
[COLOR=#ff0000] Application.DisplayAlerts = True[/COLOR]
End Sub

De andere vraag over je kopieeractie zal ik nog eens naar kijken.

 

[HSV]

Je andere vraag over het kopiëren van een werkblad:
Zet het vinkje bij "kopie maken".

Althans zo werkt het bij mij.

 

[dartfreak1987]

de nieuwe macro werkt dus helemaal niet

en dat met dat vinkje heb ik gedaan maar dan zegt hij dat het volgende fout is:
ActiveSheet.Name = Wb.Range("j13").Value dit geeft hij in het geel aan

 

[HSV]

1: De code over de USB werkt perfect.

2: Wat heeft het handmatig kopiëren van een werkblad met een foutmelding van Vba code van doen.

 

[dartfreak1987]

1 ik weet al wat ik fout gedaan heb was vergeten de juiste cellen er neer te zetten

2 dat weet ik niet want ik heb niet echt verstand van vba

ik geef nu alleen het probleem door wat ik tegen kom

wat me wel is opgevallen is dat jij andere cellen hebt staan dan mij
kan het hier aan liggen

oplossing van het kopiëren gevonden
de naam wat tussen haakjes staat had ik dus niet aangepast aan het tabblad naam
Set Wb = ThisWorkbook.Sheets("inschrijving")

die aangepast en doet wel kopiëren

alleen deze doet het bij mij dus niet

Sub hsv()
Dim Wb As Object, cp, sh As Shape, dr, drletter
Application.DisplayAlerts = False
On Error Resume Next
For Each dr In CreateObject("scripting.filesystemobject").drives
If dr.drivetype = 1 Then drletter = dr.driveletter
Next


Set Wb = ThisWorkbook.Sheets("inschrijving")
With GetObject(drletter & ":" & Wb.Range("j19") & ".xls")
.Sheets(CStr(Wb.Range("I5").Value)).Copy , ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ActiveSheet.Name = Wb.Range("I5").Value
Wb.Columns(3).Copy ThisWorkbook.Sheets(CStr(Wb.Range("I5").Value)).Columns(1)
.Close 0
End With
Application.DisplayAlerts = True
End Sub

moet ik hier ergens iets in aanpassen?

 

[HSV]

Volgens mij doe jij iets totaal overbodigs.
Kopieer de code die ik plaatste in plaats van overtypen.

Ik zie de fout in een oogwenk.

 

[dartfreak1987]

ik doe hem ook kopieren

ik moet alleen van de i5 l6 maken
en van de andere i5 j13 maken (2x)

 

[HSV]

Bekijk het nog eens rustig.
Wat ontbreekt er hier?

[COLOR=#333333]With GetObject(drletter & ":" & Wb.Range("j19") & ".xls")[/COLOR]

 

[dartfreak1987]

de drive letter

moet ik die ipv drletter zetten
of ipv ":"

en als het drletter is moet dat dan bij ze allemaal?