• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

VBA Excel bestand opslaan met naam vanuit cel

Status
Niet open voor verdere reacties.

Maestr0

Gebruiker
Lid geworden
1 mrt 2021
Berichten
16
Goedemiddag.

Ik heb een werkmap met 2 tabbladen.
Het eerste tabblad is een overzicht van gegevens welke uit een formulier (klachtformulier)worden gehaald welke op het andere tabblad staat.
Op het formulier zit een opslaan button waardoor de gegevens van het formulier ingevuld worden in het overzicht en het formulier apart als excel opgeslagen wordt.

Dit mag in dezelfde map, in mijn one drive omgeving, echter zou het de naam moeten krijgen welke in een cel (A39)van het formulier staat.
Met onderstaand wordt er wel aangeboden in de juiste map te slaan, echter krijgt het document niet de naam mee uit cel A39 maar "map1"

Ik ben geen VBA expert en ben nu een heel eind gekomen door veel te zoeken en samen te voegen uit allerlei andere vragen.
Enkel dit laatste krijg ik niet voor elkaar.

Wie kan mij op weg helpen(als mijn vraag al duidelijk is..)

Bij voorbaat dank!

Met vriendelijke groet,


Code:
End With

  'Opslaan klachtenformulier,
  Sheets("Klachtformulier").Copy
  
  ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path & "" & Range("A39") & ".xls"
  ActiveWindow.Close

  'Leeg maken klachtenformulier
  ShonenKlachtenformulier

  MsgBox "Gegevens opgeslagen.", vbInformation, "Klaar"


End Sub
 
Laatst bewerkt door een moderator:
Welke versie van Office gebruik je?
 
test deze eens
Code:
Sub atest()
Dim Fname As String
Fname = Sheets("Klachtenformulier").Range("A39") & ".xls"
Sheets("Klachtformulier").Copy
With ActiveWorkbook
    .SaveAs Filename:=Fname
    .Close
End With
'Leeg maken klachtenformulier
ShonenKlachtenformulier

MsgBox "Gegevens opgeslagen.", vbInformation, "Klaar"
End Sub
 
Laatst bewerkt:
Ik gebruik Office 365
 
Laatst bewerkt door een moderator:
Dan moet je niet de .xls extensie gebruiken, die is voor Office 2003.
Gebruik dan .xlsx (51) voor een document zonder macro's en .xlsm (52) voor een document met macro's.
Wil je een document met macro's opslaan als een document zonder macro's dan doe je dit:
Code:
Application.DisplayAlerts = False
Fname = Sheets("Klachtenformulier").Range("A39") & ".xlsx"
ThisWorkbook.SaveAs Filename:=Fname, 51
Application.DisplayAlerts = True
 
Laatst bewerkt:
Er staat in mijn VBA code ook nog een stukje boven. dat zal ik even mee kopiëren. Ik plak het denk ik niet op de juiste locatie in.

Code:
Public Sub OpslaanKlacht()

  Dim lRegel   As Long

  If Range("B6") = "" Then MsgBox "geen klachtnr", vbCritical: End

  'Wegschrijven van de klacht in de tabel.
  With Sheets("Overzicht 2021")
    On Error Resume Next
    lRegel = WorksheetFunction.Match(Range("B6"), .Range("A:A"), 0)
    If lRegel = 0 Then lRegel = .Range("A" & .Rows.Count).End(xlUp).Offset(1).Row
    lRegel = lRegel - 1
    .Range("A1").Offset(lRegel, 0) = Range("B6")
    .Range("A1").Offset(lRegel, 1) = Range("G9")
    .Range("A1").Offset(lRegel, 2) = Range("G7")
    .Range("A1").Offset(lRegel, 3) = Range("G10")
    .Range("A1").Offset(lRegel, 4) = Range("B9")
    .Range("A1").Offset(lRegel, 5) = Range("B10")
    .Range("A1").Offset(lRegel, 6) = Range("B4")
    .Range("A1").Offset(lRegel, 7) = Range("A13")
    .Range("A1").Offset(lRegel, 8) = Range("B7")
    .Range("A1").Offset(lRegel, 9) = Range("G35")

  Sub atest()
Dim Fname As String
Fname = Sheets("Klachtenformulier").Range("A39") & ".xls"
Sheets("Klachtformulier").Copy
With ActiveWorkbook
    .SaveAs Filename:=Fname
    .Close
End With
'Leeg maken klachtenformulier
ShonenKlachtenformulier

MsgBox "Gegevens opgeslagen.", vbInformation, "Klaar"


End Sub



Hoe maken jullie zo'n mooi code vakje?:o

Bij voorbaat dank voor alle hulp!!
 
Laatst bewerkt door een moderator:
Ik heb de code ingeplakt waar ik denk dat die hoort, werkt niet, zie onderstaande melding.
Ik zal hem wel verkeerd inplakken.

Ik hoor het graag !

Bij voorbaat dank!!

Bekijk bijlage 355794
 
Laatst bewerkt door een moderator:
Ik had er ook een foutje in gemaakt wegens niet goed lezen.
Aangepast in #5
 
Dit stukje code wordt als fout gemarkeerd.

ThisWorkbook.SaveAs Filename:=Fname, 51
 
Laatst bewerkt door een moderator:
Dat stukje is weer afhankelijk van wat er omheen staat en kan ik dus zo niks van zeggen.
Je bijlage in #7 is niet zichtbaar.
 
Dit is de hele code.

Code:
Public Sub OpslaanKlacht()

  Dim lRegel   As Long

  If Range("B6") = "" Then MsgBox "geen klachtnr", vbCritical: End

  'Wegschrijven van de klacht in de tabel.
  With Sheets("Overzicht 2021")
    On Error Resume Next
    lRegel = WorksheetFunction.Match(Range("B6"), .Range("A:A"), 0)
    If lRegel = 0 Then lRegel = .Range("A" & .Rows.Count).End(xlUp).Offset(1).Row
    lRegel = lRegel - 1
    .Range("A1").Offset(lRegel, 0) = Range("B6")
    .Range("A1").Offset(lRegel, 1) = Range("G9")
    .Range("A1").Offset(lRegel, 2) = Range("G7")
    .Range("A1").Offset(lRegel, 3) = Range("G10")
    .Range("A1").Offset(lRegel, 4) = Range("B9")
    .Range("A1").Offset(lRegel, 5) = Range("B10")
    .Range("A1").Offset(lRegel, 6) = Range("B4")
    .Range("A1").Offset(lRegel, 7) = Range("A13")
    .Range("A1").Offset(lRegel, 8) = Range("B7")
    .Range("A1").Offset(lRegel, 9) = Range("G35")

  End With

  'Opslaan klachtenformulier,
  Sheets("Klachtformulier").Copy
  
  Applicatiion.DisplayAlerts = False
Fname = Sheets("Klachtenformulier").Range("A39") & ".xlsx"
ThisWorkbook.SaveAs Filename:=Fname, 51
Applicatiion.DisplayAlerts = True

  ActiveWindow.Close

  'Leeg maken klachtenformulier
  ShonenKlachtenformulier

  MsgBox "Gegevens opgeslagen.", vbInformation, "Klaar"


End Sub
 
Laatst bewerkt door een moderator:
Maak er dan dit van:
Code:
Public Sub OpslaanKlacht()

Dim lRegel As Long

If Range("B6") = "" Then MsgBox "geen klachtnr", vbCritical: End

'Wegschrijven van de klacht in de tabel.
With Sheets("Overzicht 2021")
On Error Resume Next
lRegel = WorksheetFunction.Match(Range("B6"), .Range("A:A"), 0)
If lRegel = 0 Then lRegel = .Range("A" & .Rows.Count).End(xlUp).Offset(1).Row
lRegel = lRegel - 1
.Range("A1").Offset(lRegel, 0) = Range("B6")
.Range("A1").Offset(lRegel, 1) = Range("G9")
.Range("A1").Offset(lRegel, 2) = Range("G7")
.Range("A1").Offset(lRegel, 3) = Range("G10")
.Range("A1").Offset(lRegel, 4) = Range("B9")
.Range("A1").Offset(lRegel, 5) = Range("B10")
.Range("A1").Offset(lRegel, 6) = Range("B4")
.Range("A1").Offset(lRegel, 7) = Range("A13")
.Range("A1").Offset(lRegel, 8) = Range("B7")
.Range("A1").Offset(lRegel, 9) = Range("G35")

End With

'Opslaan klachtenformulier,
Sheets("Klachtformulier").Copy

Application.DisplayAlerts = False
Fname = Sheets("Klachtenformulier").Range("A39") & ".xlsx"
ThisWorkbook.SaveAs Fname, 51
Application.DisplayAlerts = True

ActiveWindow.Close

'Leeg maken klachtenformulier
shonenKlachtenformulier

MsgBox "Gegevens opgeslagen.", vbInformation, "Klaar"


End Sub
 
Waarom niet in een 1 dimensionaal array?

Code:
On error resume next
lijkt me ook totaal overbodig.

De Match functie kan je afvangen met:
Code:
if isnumeric

De code wordt al een aardig stuk ingekort dan.
 
Onderstaand deel kan denkik wel vervangen worden

Code:
.Range("A1").Offset(lRegel, 0) = Range("B6")
.Range("A1").Offset(lRegel, 1) = Range("G9")
.Range("A1").Offset(lRegel, 2) = Range("G7")
.Range("A1").Offset(lRegel, 3) = Range("G10")
.Range("A1").Offset(lRegel, 4) = Range("B9")
.Range("A1").Offset(lRegel, 5) = Range("B10")
.Range("A1").Offset(lRegel, 6) = Range("B4")
.Range("A1").Offset(lRegel, 7) = Range("A13")
.Range("A1").Offset(lRegel, 8) = Range("B7")
.Range("A1").Offset(lRegel, 9) = Range("G35")

Door:

Code:
.Range("A1").Offset(lRegel).Resize(, 10) = Array([B6], [G9], [G7], [G10], [B9], [B10], [B4], [A13], [B7], [G35])
 
Laatst bewerkt:
Tja, dat schreef ik net een paar minuten voor je aan.
 
Je kunt het zo proberen, is al een stuk korter. Kan zijn dat je nog iets moet aanpassen, heb je bestand niet om te testen.

Code:
Public Sub OpslaanKlacht()
Application.DisplayAlerts = False
 If Range("B6") = "" Then MsgBox "geen klachtnr", vbCritical: End
    With Sheets("Overzicht 2021")
       lRegel = Application.Match(Range("B6"), .Range("A:A"), 0) - 1
       If Not IsNumeric(lRegel) Then lRegel = .Range("A" & .Rows.Count).End(xlUp).Offset(1).Row - 1
      .Range("A1").Offset(lRegel).Resize(, 10) = Array([B6], [G9], [G7], [G10], [B9], [B10], [B4], [A13], [B7], [G35])
       Fname = Sheets("Klachtenformulier").Range("A39") & ".xlsx"
       Sheets("Klachtformulier").Copy
       ThisWorkbook.SaveAs Fname, 51
       ActiveWindow.Close
       shonenKlachtenformulier
       MsgBox "Gegevens opgeslagen.", vbInformation, "Klaar"
    End With
Application.DisplayAlerts = True
End Sub
 
Wauw jullie zijn echt awesome zo snel te reageren en te willen helpen!!

Ik zal de tips om de code in te korten proberen, nadat ik werkend heb wat ik nodig heb... anders dwaal ik misschien alleen maar verder af.

Ik heb de code in #12 geprobeerd, dat werkt niet zoals mijn bedoeling is en hij lijkt dan het hele document als enkel het klachtformulier op te slaan en de data niet te verwerken in het overzicht tabblad.

Ik heb echter zitten lezen en geprobeerd de code zoals die voorgesteld wordt te begrijpen. Ik had eerst als document type .xls, daarvan werd aangegeven dat dat niet klopte.
Dus van .xls .xlsx gemaakt en nu gaat het opslaan en wegschrijven van data naar het overzicht tabblad goed.

ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path & "" & Range("A39") & ".xlsx"
ActiveWindow.Close

Enige is de locatie waar opgeslagen word is niet juist.

Ik open het bestand vanuit een map in onedrive welke met collega's gedeeld wordt. het tabblad klachten formulier moet ook in die map opgeslagen worden. Nu schrijft ie hem op mijn E:\ weg..

Het stukje ActiveWorkbook.Path & "" is dus niet juist. nu zie ik in de codes welke voorgesteld dit niet terug komen, dus verwijderen?

En dan zoiets overhouden? ActiveWorkbook.SaveAs Filename:= Range("A39") & ".xlsx" ( getest, dan gooit ie hem in mijn documenten)

Vraag is dus hoe sla ik op in mijn onedrive?
 
Die nieuw aangemaakt bestand wordt zomaar weggegooid?
Waarom zou je van die blad dan een copy maken?

Overigens kan 'Application.displayalerts = true' er ook wel uit; gaat automatisch weer op true aan het einde van de code.
 
@Meastr0, ik heb de onnodige quotes eruit gehaald en je code in de tags gezet. Dat kun jij ook gebruik de knop reageer op bericht links onderaan om te reageren op dit topic.
En gebruik dan in het veld waarin je typt de knop # en je code in de tags te zetten.
 
Na nog veel lezen en proberen heb ik nu deze code:

Code:
  'Opslaan klachtenformulier,
  Sheets("Klachtformulier").Copy
  
  ActiveWorkbook.SaveAs filename:= _
        "https://pcborotterdamzuid.sharepoint.com/sites/PCBOTechnischeDienst/Gedeelde%20documenten/6%20-%20Gemeente/2%20-%20Schade-Vandalisme-Lekkage/schademelding%20Formulier .xlsx"
  ActiveWindow.Close

Dan wordt het werkblad in de juiste map opgeslagen in onedrive met schademelding formulier als naam.
Hier ben ik al zeer blij mee.

Mooier zou nog zijn als er automatisch cel G9 aan die naam toegevoegd zou worden.

Bij voorbaat dank voor suggesties!!
 
Status
Niet open voor verdere reacties.
Terug
Bovenaan Onderaan