VBA Excel bestand opslaan met naam vanuit cel

Maestr0 · 1 mrt 2021

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

edmoor · 1 mrt 2021

Welke versie van Office gebruik je?

JeanPaul28 · 1 mrt 2021

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

Maestr0 · 1 mrt 2021

Ik gebruik Office 365

edmoor · 1 mrt 2021

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

Maestr0 · 1 mrt 2021

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?

Bij voorbaat dank voor alle hulp!!

Maestr0 · 1 mrt 2021

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

edmoor · 1 mrt 2021

Ik had er ook een foutje in gemaakt wegens niet goed lezen.
Aangepast in #5

Maestr0 · 1 mrt 2021

Dit stukje code wordt als fout gemarkeerd.

ThisWorkbook.SaveAs Filename:=Fname, 51

edmoor · 1 mrt 2021

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.

Maestr0 · 1 mrt 2021

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

edmoor · 1 mrt 2021

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

HSV · 1 mrt 2021

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.

JEC. · 1 mrt 2021

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])

HSV · 1 mrt 2021

Tja, dat schreef ik net een paar minuten voor je aan.

JEC. · 1 mrt 2021

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

Maestr0 · 1 mrt 2021

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?

HSV · 1 mrt 2021

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.

puppie · 2 mrt 2021

@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.

Maestr0 · 3 mrt 2021

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!!

VBA Excel bestand opslaan met naam vanuit cel

Gebruiker

Inventaris

Terugkerende gebruiker

Gebruiker

Inventaris

Gebruiker

Gebruiker

Inventaris

Gebruiker

Inventaris

Gebruiker

Inventaris

Inventaris

Terugkerende gebruiker

Inventaris

Terugkerende gebruiker

Gebruiker

Inventaris

Supermoderator

Gebruiker

Wij waarderen jouw privacy