Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Tabelle als .xlsx speichern
28.09.2016 09:23:22
Michael
Hallo Excel Freunde
bräuchte mal eure Hilfe , im nachfolgendem Code wird ein excelblatt ausgefüllt uber MsgBoxen und sobald die letzte ausgefüllt wird speichert er das Blatt als PDF im vorgesehenen Ordner , das funktioniert auch sehr gut nur brauche ich für die Arbeit die Datei als .xlsx Datei in dem Ordner.
Oder gibt es eine möglichkeit das man auswählen kann ob PDF oder .xlsx Speichern.
Die Mappe kann ich leider nicht schicken wegen Datenschutz der Firma.
Hier der Code:
Private Sub cb_lackiert_1_Click()
ChDrive "J"
ChDir "J:\KOW\Eingang\Oberflächenformulare"
Workbooks.Open Filename:=("Formular Oberflächenfreigabe lackiert Englisch.xlsm")
Oberflächenformulare.Hide
zahl0 = InputBox("Vorstellung Neuwerkzeug? Wenn JA, dann Eingabe mit X - Wenn Nein, dann mit ENTER weiter")
zahl1 = InputBox("Vorstellung aus der Produktion? Wenn JA, dann Eingabe mit X - Wenn Nein, dann mit ENTER weiter")
zahl2 = InputBox("Bitte geben Sie die Zeichnungsnummer ein")
zahl3 = InputBox("Bitte geben Sie den Änderungsindex ein")
zahl4 = InputBox("Bitte geben Sie die Equipment-Werkzeug ein")
zahl5 = InputBox("Bitte geben Sie die Teilebezeichnung ein")
zahl6 = InputBox("Bitte geben Sie die Fachzahl ein")
zahl7 = InputBox("Bitte geben Sie die Materialbezeichnung ein")
zahl8 = InputBox("Bitte geben Sie die Materialnummer ein")
zahl9 = InputBox("Bitte geben Sie die Projektnummer ein")
zahl10 = InputBox("Bitte geben Sie die Projektbezeichnung ein")
zahl11 = InputBox("Bitte geben Sie Ihren Namen ein")
zahl12 = InputBox("Bitte geben Sie das Datum ein")
Zahl13 = InputBox("Vorstellung Durch Schichtführer? Wenn JA, dann Eingabe mit X - Wenn Nein, dann mit ENTER weiter")
zahl14 = InputBox("Vorstellung Durch Spritztechnikum? Wenn JA, dann Eingabe mit X - Wenn Nein, dann mit ENTER weiter")
zahl15 = InputBox("Vorstellung Durch Werkzeugtechnik? Wenn JA, dann Eingabe mit X - Wenn Nein, dann mit ENTER weiter")
zahl16 = InputBox(" Werzeug produktionsfähig? Wenn JA, dann Eingabe mit X - Wenn Nein, dann mit ENTER weiter")
Zahl17 = InputBox(" Oberflächenbeurteilung Neuwerkzeuge? Wenn JA, dann Eingabe mit X - Wenn Nein, dann mit ENTER weiter")
zahl18 = InputBox(" Oberflächenbeurteilung für MFU? Wenn JA, dann Eingabe mit X - Wenn Nein, dann mit ENTER weiter")
zahl19 = InputBox(" Oberflächenbeurteilung nach Wz. Optimierung/Korrektur? Wenn JA, dann Eingabe mit X - Wenn Nein, dann mit ENTER weiter")
zahl20 = InputBox("Weitergabe an Lackiererei - Schuss / Satz eingeben")
Zahl21 = InputBox("Bitte geben Sie das Datum ein")
zahl22 = InputBox("Bemerkung: Zeile 1 max 74 Zeichen")
Zahl23 = InputBox("Bemerkung: Zeile 2 max 86 Zeichen")
zahl = InputBox("Anzahl Ausdrucke?", , "1")
'If zahl = "" Then GoTo Schließen
Range("H3").Select
ActiveCell.FormulaR1C1 = zahl0
Range("R3").Select
ActiveCell.FormulaR1C1 = zahl1
Range("I6").Select
ActiveCell.FormulaR1C1 = zahl2
Range("Q6").Select
ActiveCell.FormulaR1C1 = zahl3
Range("I8").Select
ActiveCell.FormulaR1C1 = zahl4
Range("I10").Select
ActiveCell.FormulaR1C1 = zahl5
Range("V10").Select
ActiveCell.FormulaR1C1 = zahl6
Range("I12").Select
ActiveCell.FormulaR1C1 = zahl7
Range("I14").Select
ActiveCell.FormulaR1C1 = zahl8
Range("I16").Select
ActiveCell.FormulaR1C1 = zahl9
Range("V16").Select
ActiveCell.FormulaR1C1 = zahl10
Range("I18").Select
ActiveCell.FormulaR1C1 = zahl11
Range("V18").Select
ActiveCell.FormulaR1C1 = zahl12
Range("H22").Select
ActiveCell.FormulaR1C1 = Zahl13
Range("U22").Select
ActiveCell.FormulaR1C1 = zahl14
Range("AE22").Select
ActiveCell.FormulaR1C1 = zahl15
Range("S25").Select
ActiveCell.FormulaR1C1 = zahl16
Range("S26").Select
ActiveCell.FormulaR1C1 = Zahl17
Range("S27").Select
ActiveCell.FormulaR1C1 = zahl18
Range("S28").Select
ActiveCell.FormulaR1C1 = zahl19
Range("R30").Select
ActiveCell.FormulaR1C1 = zahl20
Range("I36").Select
ActiveCell.FormulaR1C1 = Zahl21
Range("G37").Select
ActiveCell.FormulaR1C1 = zahl22
Range("G38").Select
ActiveCell.FormulaR1C1 = Zahl23
'If zahl = "" Then GoTo Schließen
Range("A1:AF149").Select
With Selection
.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:="J:\KOW\Eingang\Oberflächenformulare\Vorstellung\Oberflächenfreigabe lackiert Englisch_" & Range("I6") & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=True, OpenAfterPublish:=False
.PrintPreview
End With
Gruß Michael

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Tabelle als .xlsx speichern
28.09.2016 10:07:44
UweD
Hallo
erstmal:
- Select braucht man in 99% der Fälle nicht
- deshalb kannst du das so machen..
- Warum nutzt du nicht anstelle der vielen Inputboxen eine Userform mit den entsprechenden Eingabefeldern?
der Rest so...
Private Sub cb_lackiert_1_Click()
    On Error GoTo Fehler
    Dim Pfad$, Datei$, FFormat$
    Pfad = "J:\KOW\Eingang\Oberflächenformulare\"
    Pfad = "C:\Temp\"
    Datei = "Formular Oberflächenfreigabe lackiert Englisch"
    ChDir Pfad
    Workbooks.Open Filename:=(Datei & ".xlsm")
    'Oberflächenformulare.Hide 
    
    
    Range("H3") = InputBox("Vorstellung Neuwerkzeug? Wenn JA, dann Eingabe mit X - Wenn Nein, dann mit ENTER weiter")
    Range("R3") = InputBox("Vorstellung aus der Produktion? Wenn JA, dann Eingabe mit X - Wenn Nein, dann mit ENTER weiter")
    '... 
    
    FFormat = InputBox("Speichern als" & vbLf & vbLf & "    (P)df" & vbLf & "    (X)lsx", "Formatauswahl", "P")
    'If zahl = "" Then GoTo Schließen 
    
    With Range("A1:AF149")
        If UCase(FFormat) = "P" Then
            .ExportAsFixedFormat Type:=xlTypePDF, _
                Filename:=Pfad & Datei & "_" & Range("I6") & ".pdf", _
                Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                IgnorePrintAreas:=True, OpenAfterPublish:=False
        ElseIf UCase(FFormat) = "X" Then
            Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs Filename:=Pfad & Datei & "_" & Range("I6") & ".xlsx", _
                FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        End If
        .PrintPreview
    End With
    Err.Clear
Fehler:
    Application.DisplayAlerts = True
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear
End Sub
LG UweD
Anzeige
AW: Tabelle als .xlsx speichern
28.09.2016 13:10:36
Michael
Hallo Uwe
Danke erstmal für deine Antwort .
Wo muss ich das denn einfügen da wo das mit dem PDF Speicher steht.
Gruß Michael
AW: Tabelle als .xlsx speichern
28.09.2016 14:44:55
UweD
Hallo
Verstehe nicht ganz:
&GT&GT Wo muss ich das denn einfügen da wo das mit dem PDF Speicher steht.
das ist doch das komplette Makro...
nur deine Zellzuweisungen habe ich für 2 Zellen exemplarisch gemacht,
den Rest darfts du umbauen
Die Abfrage ob als PDF oder XLSX ist diese Teil hier
    'Abfrage wie gespeichert werden soll 
    FFormat = InputBox("Speichern als" & vbLf & vbLf & _
        "    (P)df" & vbLf & "    (X)lsx", "Formatauswahl", "P")
    
    
    With Range("A1:AF149")
        If UCase(FFormat) = "P" Then ' als PDF 
            .ExportAsFixedFormat Type:=xlTypePDF, _
                Filename:=Pfad & Datei & "_" & Range("I6") & ".pdf", _
                Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                IgnorePrintAreas:=True, OpenAfterPublish:=False
        ElseIf UCase(FFormat) = "X" Then ' als xlsx 
            Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs Filename:=Pfad & Datei & "_" & Range("I6") & ".xlsx", _
                FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        End If
        .PrintPreview
    End With
LG UweD
Anzeige
AW: Tabelle als .xlsx speichern
28.09.2016 15:15:56
Michael
Okay super danke jetzt hab ich es kapiert.
Gruß Michael
Danke für die Rückmeldung owT
28.09.2016 15:32:00
UweD
AW: Danke für die Rückmeldung owT
28.09.2016 17:48:49
Michael
Hallo Uwe
Hab das Makro jetzt mal übernommen und den Pfad geändert aber er bringt immer den Fehler 1004 oder Fehler 76 Pfad nicht gefunden.
Der Pfad lautet:J\KOW\Eingang\Oberflächenformulare
Was mach ich falsch
Gruß Michael
AW: Danke für die Rückmeldung owT
29.09.2016 08:37:04
UweD
Hallo nochmal
- Der 2. Pfadeintrag war nur für mein Testen. Den musst du löschen
- Hast du hinten auch den Backslash angefügt \
Pfad = "J:\KOW\Eingang\Oberflächenformulare\"
Pfad = "C:\Temp\"
LG UweD
AW: Danke für die Rückmeldung owT
29.09.2016 16:55:49
Michael
Danke Uwe
Jetzt funktioniert es.
Vielen Dank und Gruß Michael
Anzeige
AW: Prima!
30.09.2016 08:53:11
UweD

327 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige