Makroanpassung für Öffnen und speichern als

Question

Hallo
Dies ist mein erstes Post, und ich habe gleich eine Frage.

Letzte Woche habe ich zum erstenmal mit dem Makro-recorder ein Makro erstellt.
Ich bin angenehm überrascht wie leicht das war sowie wie perfekt das funktioniert.

Meine Aufgabe war folgende.
Aus einem Messgerät werden von verschiedenen Kollegen Daten im Text-format ausgelesen.
Meine Ursprungsdateien heissen z.b.: Berlin-1.txt, Berlin-2.txt, Köln-1.txt, München-1.txt

Mein aufgezeichnetes Makro kennt aber nur den Namen der dabei bearbeiteten Anfangsdatei sowie der dabei abgespeicherte Dateinamen.
Ich denke dass es nötig ist den Anfang sowie den Schluss meines Makros durch editieren anzupassen.

Bei dem Öffnen sollte ich gefragt welche von den Text-dateien aus den Ordner C.\Daten\ ich bearbeiten will.
.....
.....
Zum Schluss wäre es toll wenn wenn ich gefragt würde in welchen Ordner sowie unter unter welchem Namen die die Arbeitsmappe abgespeichert werden soll.
Gewünscht wäre wenn automatisch vorgeschlagen würde dass der Namen der Arbeitsmappe aus dem Namen der ursprünglich importierten Daten abgeleitet würde.
Beispiel: aus: Berlin-1.txt soll nachher die Arbeitsmappe: Berlin-1.xlsx werden.
Ideal wäre auch dass das Makro sich merken könnte in welchem Ordner die vorige Datei abgespeichert worden ist.
So müsste man sich nicht jeweils für sämtliche Berlin-x, Köln-x, oder München x Dateien durch die ganze Festplatte(n) klicken um den gewünschten Ort festzulegen.

Ich habe den grössten Teil des Wochenendes mich mit der Suche nach einer Lösung befasst.
Es wäre toll wenn jemand mir einen Tipp geben könnte oder eventuell sagen könnt wo ich nach einer Lösung suchen könnte.

Besten Dank und freundliche Grüsse.

Answer 1

Hallo Paul,

da du dein vorhandenes Makro nicht postest hier mal ein Code, mit dem du experimentieren kannst und in den du deinen vorhanden Code ggf. einbauen kannst:

Sub oeffnen_speichern()

Dim varName As Variant
Dim strPfad As String
Dim strName As String
Dim Neuer_Dateiname As String

'Laufwerk und Pfad zum Öffnen vorgeben
ChDrive "C"
ChDir "C:\Daten"

'Datei-Öffnen-Dialog aufrufen
varName = Application.GetOpenFilename("Text-Dateien (*.txt),*.txt")

'Letztes \ ermitteln um Pfad und Dateiname zu trennen
strPfad = Left(varName, InStrRev(varName, "\"))
strName = Right$(varName, Len(varName) - InStrRev(varName, "\"))

'Letzten . ermitteln um Dateiname und Erweiterung zu trennen
strName = Left(strName, InStrRev(strName, ".") - 1)

'Ausgabe - hier dein Makro
MsgBox strPfad & Chr(10) & strName

'ggf. abweichenden Pfad festlegen
'Stadt ermitteln
strStadt = Left(strName, InStrRev(strName, "-") - 1)
'Pfad der entsprechenden Stadt zuweisen
If strStadt = "München" Then strPfad = "C:\Daten\München\"
If strStadt = "Berlin" Then strPfad = "C:\Daten\Berlin\"
If strStadt = "Hamburg" Then strPfad = "C:\Daten\Hamburg\"

'Speichern-unter Dialog aufrufen
Neuer_Dateiname = Application.GetSaveAsFilename(InitialFileName:=strPfad & strName & ".xlsx", fileFilter:="Excel-Arbeitsmappe, *.xlsx")
'falls kein Name eingegeben wird, Makro verlassen
If Neuer_Dateiname = False Then Exit Sub
'aktive Arbeitsmappe speichern
ActiveWorkbook.SaveAs Filename:=Neuer_Dateiname

End Sub

Ideal wäre auch dass das Makro sich merken könnte in welchem Ordner die vorige Datei abgespeichert worden ist.

Das mit dem merken ist für ein Makro etwas schwierig ;-). Daher würde ich den Pfad zum Speichern vorgeben, wenn dieser nicht identisch mit dem Pfad aus dem Öffnen-Dialog ist.

Gruß

M.O.

Answer 2

Hallo

Einen grossen Dank an M.O. für deine Antwort sowie für die Beschreibung wofür die / und . gesetzt werden.

Wie Ihr seht ist mein Excel (2013) auf Englisch. Die Anpassung deutsch(english traue ich mir zu.

Die Unterteilung in verschiedene Ordner für die einzelnen Städte ist nicht nötig.
Pro Stadt gibt es eh nur max. 3 Datensätze.

Es wäre vorteilhaft wenn der Name der späteren Excel-Datei direkt aus dem Namen der Eingangs-text-datei vorgegeben würde.
bsp.: aus einer Datei: Berlin-1.txt wird nach dem Durchlauf eine Berlin-1.xlsx
Dadurch wird vermieden dass jemand vergisst den Namen (speichern_unter) anzupassen und eine andere Datei überschreibt.
Einfachshalber werden alle bearbeiteten xlsx-Dateien einfach in den Ordner C:\Akku\ abgespeichert.
Wahrscheinlich unterteile ich diesen Ordner aber noch in Input und Output.

Danke




Sub BattMacro1()
'
' BattMacro1 Macro
' Batt
'

'
ChDir "C:\Akku"
Workbooks.OpenText Filename:="C:\Akku\Batt-data.txt", Origin:=xlWindows, _
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, Comma:=False, _
Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3 _
, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, _
1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), _
Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1), Array( _
23, 1), Array(24, 1), Array(25, 1), Array(26, 1)), DecimalSeparator:=".", _
TrailingMinusNumbers:=True
Range("A1").Select
ActiveCell.FormulaR1C1 = "0.25"
Range("A2").Select
ActiveCell.FormulaR1C1 = "0.5"
Range("A1:A2").Select
Selection.AutoFill Destination:=Range("A1:A276"), Type:=xlFillDefault
Range("A1:A276").Select
ActiveWindow.ScrollRow = 270
ActiveWindow.ScrollRow = 269
ActiveWindow.ScrollRow = 268

........

ActiveWindow.ScrollRow = 240
ActiveWindow.ScrollRow = 241
ActiveWindow.ScrollRow = 242
ActiveWindow.ScrollRow = 244
ActiveWindow.SmallScroll Down:=3
Range("Z1:AA277").Select
ActiveSheet.Shapes.AddChart2(227, xlLine).Select
ActiveChart.SetSourceData Source:=Range("'Batt-data'!$Z$1:$AA$277")
ActiveChart.Location Where:=xlLocationAsNewSheet, Name:="Total"
Sheets("Batt-data").Select
Sheets("Batt-data").Move Before:=Sheets(1)
Range("AB258").Select
ActiveWorkbook.SaveAs Filename:="C:\Akku\Batt-data.xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
End Sub

Answer 3

Hallo,

hier mal das angepasste Makro:

Sub Import()

Dim varName As Variant
Dim strName As String
Dim Neuer_Dateiname As String
Dim strTabname As String
Dim oChrt As ChartObject
Dim Chrt As Chart
Dim loletzte As Long
Dim strPfad As String

'Pfad festlegen
strPfad = "C:\Akku\"
'Laufwerk und Pfad zum Öffnen vorgeben
ChDrive "C"
ChDir strPfad

'Datei-Öffnen-Dialog aufrufen
varName = Application.GetOpenFilename("Text-Dateien (*.txt),*.txt")

'Letztes \ ermitteln um Pfad und Dateiname zu trennen
strName = Right$(varName, Len(varName) - InStrRev(varName, "\"))

'Letzten . ermitteln um Dateiname und Erweiterung zu trennen
strName = Left(strName, InStrRev(strName, ".") - 1)

'hier nun dein Makroteil - teilweise modifiziert
Workbooks.OpenText Filename:=varName, Origin:=xlWindows, _
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, Comma:=False, _
Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3 _
, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, _
1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), _
Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1), Array( _
23, 1), Array(24, 1), Array(25, 1), Array(26, 1)), DecimalSeparator:=".", _
TrailingMinusNumbers:=True

'Werte in Zellen A1 und A2 schreiben
Range("A1") = "0.25"
Range("A2") = "0.5"

'letzte Zeile in Spalte A im aktiven Blatt ermitteln
loletzte = ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

'Werte auffüllen
With Range("A1:A2")
.AutoFill Destination:=Range("A1:A" & loletzte), Type:=xlFillDefault
End With

'Name des aktiven Arbeitsblattes in Variable schreiben
strTabname = ActiveWorkbook.ActiveSheet.Name

'Chart einfügen
Set Chrt = ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Sheets(Sheets.Count), Type:=xlChart)
With Chrt
.Name = "Total"
.ChartType = xlLine
.SetSourceData Source:=ActiveWorkbook.Sheets(strTabname).Range("$Z$1:$AA$" & loletzte)
End With

'Tabellenblatt an Anfang stellen
ActiveWorkbook.Sheets(strTabname).Move Before:=ActiveWorkbook.Sheets(1)

'Speichern-unter Dialog aufrufen
Neuer_Dateiname = Application.GetSaveAsFilename(InitialFileName:=strPfad & strName & ".xlsx", fileFilter:="Excel-Arbeitsmappe, *.xlsx")
'falls Abbrechen gedrückt wird, Makro verlassen
If Neuer_Dateiname = "Falsch" Then
'Meldung Makroabbruch
MsgBox "Workbook not saved!", 48, "Abort by user"
Exit Sub
End If
'aktive Arbeitsmappe speichern
ActiveWorkbook.SaveAs Filename:=Neuer_Dateiname

End Sub

Schau mal, ob das so funktioniert, wie du es dir vorstellst.

Gruß

M.O.

Answer 4

Hallo

Vielen Dank M.O. für deine Bemühungen.

Das mit loletzte ist super, da die Länge der Messungen sowie die daraus entstandenen Daten (=Zeilen) leicht variieren. :-))
Frage: sind dadurch alle Zeilen mit dem Inhalt: ActiveWindow.ScrollRow = 240 jetzt überflüssig ?

Bei dem Öffnen kann ich jetzt wie gewünscht auswählen welche Datei ich bearbeiten will.

Das Abspeichern geht auch wie gewünscht. Super !


Im Ablauf des Macros werden zwei Charts eingefügt.
Einmal werden dafür die Kolonnen A bis Y ausgewählt sowie einmal die Kolonnen Z und AA
Die Anpassung dieser Bereiche ist mir gelungen.

Allerdings muss ich für die Auswahl des zweiten Charts den Sheet mit den importierten Daten wieder neu anwählen.
(in meinem aufgezeichneten Macro war das: Sheets("Batt-data").Select
Ich habe versucht in Sheets("ActiveWorkbook.ActiveSheet.Name").Select umzuändern.
Leider ist da noch irgendwo der Wurm drin, denn genau da bleibt der Ablauf noch hängen :-(

Ich habe mir mal einige ebooks runtergeladen und versuche (hoffentlich nicht vergebens) mich schlau zu machen.
Morgen kann ich nichts weiter probieren. Am Donnerstag-morgen mach ich wieder einen Versuch.

Nochmals grossen Dank.
Ich wünsche alles Beste für die Feiertagen.

mfg

Answer 5

Hallo Paul,

mit den ActiveWindow.ScrollRow-Befehlen wird nur das aktuelle Fenster in die betreffende Zeile gescrollt. Die Befehle sind daher beim Makro überflüssig, da die betreffenden Zeilen, die du bei der Makroaufzeichnung durch das Scrollen erreicht und ausgewählt hast, direkt angesprochen werden.

Das Blatt mit den Daten, dessen Namen ja in der Variable strTabname gespeichert ist, kannst du wie folgt ansprechen:

ActiveWorkbook.Sheets(strTabname).Select

Mit deinem Befehl

Sheets("ActiveWorkbook.ActiveSheet.Name").Select

versuchst du ein Blatt mit dem Namen "ActiveWorkbook.ActiveSheet.Name" anzusprechen, das es natürlich nicht gibt.

Gruß

M.O.

Answer 6

Hallo

Das Makro lief wie gewünscht.
Im Makro werden Daten importiert.
Kolonne A wird angepasst, Oben wird eine neue Zeile A eingefügt und angepasst.
Dann wird die Zeitachse (=Kolonne A) an vorletzter Stelle eingefügt.
Dann wird ein Zellenbereich ausgewählt und daraus ein Chart erzeugt und als neues Blatt "Zellen" abgespeichert.
Aehnliches geschieht für das Blatt "Total"
Dann wird man gefragt ob man unter einem aus den Eingangsdatei abgeleitetem Namen als XLSX abspeichern will.
Wenn man die Arbeitsmappe dann schliessen will - wird man nochmal aufgefordert abzuspeichern.
Wählt man hiern "Nein" kommt man nicht raus.
Wählt amn "Ja" erscheint ein Hinweis dass einige Elements verloren gehen wenn man als Unicode abgespeichert.
Danach ist diese abgespeicherte Datei dann auch nicht lesbar mit Excel.

Eigentlich lief das Makro dank M.O. korrekt (inkl.abspeichern) durch.
Dann habe ich aber in beiden Charts die Legende eingefügt sowie als category und Value-achse die Wörter "Minutes" und "Volt" eingefügt.
Ich sehe leider nicht wo hier der hase im Pfeffer liegt.
Ich würde mich freuen wenn nochmal jemand mir einen kleinen Schubs geben könnte.

Ansonsten wüsche ich allen alles Gute im neuen Jahr.

Hier das Makro:
Sub BattImport()
'
' BattImport Macro
'
' Keyboard Shortcut: Ctrl+b
'

Dim varName As Variant
Dim strName As String
Dim Neuer_Dateiname As String
Dim strTabname As String
Dim oChrt As ChartObject
Dim Chrt As Chart
Dim loletzte As Long
Dim strPfad As String

'Pfad festlegen
strPfad = "C:\Akku\"
'Laufwerk und Pfad zum Öffnen vorgeben
ChDrive "C"
ChDir strPfad

'Datei-Öffnen-Dialog aufrufen
varName = Application.GetOpenFilename("Text-Dateien (*.txt),*.txt")

'Letztes \ ermitteln um Pfad und Dateiname zu trennen
strName = Right$(varName, Len(varName) - InStrRev(varName, "\"))

'Letzten . ermitteln um Dateiname und Erweiterung zu trennen
strName = Left(strName, InStrRev(strName, ".") - 1)

'hier nun dein Makroteil - teilweise modifiziert
Workbooks.OpenText Filename:=varName, Origin:=xlWindows, _
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, Comma:=False, _
Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3 _
, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, _
1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), _
Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1), Array( _
23, 1), Array(24, 1), Array(25, 1), Array(26, 1)), DecimalSeparator:=".", _
TrailingMinusNumbers:=True

'Werte in Zellen A1 und A2 schreiben
Range("A1") = "0"
Range("A2") = "0.2"
Range("A3") = "0.4"
Range("A4") = "0.6"

'letzte Zeile in Spalte A im aktiven Blatt ermitteln
loletzte = ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

'Werte auffüllen
With Range("A2:A3:A4")
.AutoFill Destination:=Range("A2:A" & loletzte), Type:=xlFillDefault
End With

'Name des aktiven Arbeitsblattes in Variable schreiben
strTabname = ActiveWorkbook.ActiveSheet.Name

Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("B1").Select
ActiveCell.FormulaR1C1 = "Zelle 1"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Zelle 2"
Range("B1:C1").Select
Selection.AutoFill Destination:=Range("B1:Y1"), Type:=xlFillDefault
Range("B1:Y1").Select
Range("Z1").Select
ActiveCell.FormulaR1C1 = "Total"
Columns("Z:Z").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
ActiveWindow.LargeScroll ToRight:=-1
Columns("A:A").Select
Selection.Copy
ActiveWindow.LargeScroll ToRight:=1
Columns("Z:Z").Select
ActiveSheet.Paste
ActiveSheet.Shapes.AddChart2(227, xlLine).Select
ActiveChart.SetSourceData Source:=ActiveWorkbook.Sheets(strTabname).Range("$A$1:$Y$" & loletzte)
ActiveChart.SetElement (msoElementChartTitleAboveChart)

ActiveChart.ChartArea.Select
ActiveChart.SetElement (msoElementLegendBottom)


ActiveChart.SetElement (msoElementPrimaryCategoryAxisTitleAdjacentToAxis)
ActiveChart.SetElement (msoElementPrimaryValueAxisTitleAdjacentToAxis)
ActiveChart.Axes(xlCategory).AxisTitle.Select
ActiveChart.Axes(xlCategory, xlPrimary).AxisTitle.Text = "Minutes"
Selection.Format.TextFrame2.TextRange.Characters.Text = "Minutes"
With Selection.Format.TextFrame2.TextRange.Characters(1, 7).ParagraphFormat
.TextDirection = msoTextDirectionLeftToRight
.Alignment = msoAlignCenter
End With
With Selection.Format.TextFrame2.TextRange.Characters(1, 7).Font
.BaselineOffset = 0
.Bold = msoFalse
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(89, 89, 89)
.Fill.Transparency = 0
.Fill.Solid
.Size = 10
.Italic = msoFalse
.Kerning = 12
.Name = "+mn-lt"
.UnderlineStyle = msoNoUnderline
.Strike = msoNoStrike
End With

ActiveChart.ChartArea.Select
ActiveChart.Axes(xlValue, xlPrimary).HasTitle = True
ActiveChart.Axes(xlValue).AxisTitle.Select
ActiveChart.Axes(xlValue, xlPrimary).AxisTitle.Text = "Volt"
Selection.Format.TextFrame2.TextRange.Characters.Text = "Volt"
With Selection.Format.TextFrame2.TextRange.Characters(1, 4).ParagraphFormat
.TextDirection = msoTextDirectionLeftToRight
.Alignment = msoAlignCenter
End With
With Selection.Format.TextFrame2.TextRange.Characters(1, 4).Font
.BaselineOffset = 0
.Bold = msoFalse
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(89, 89, 89)
.Fill.Transparency = 0
.Fill.Solid
.Size = 10
.Italic = msoFalse
.Kerning = 12
.Name = "+mn-lt"
.UnderlineStyle = msoNoUnderline
.Strike = msoNoStrike
End With




ActiveChart.PlotArea.Select
ActiveChart.ChartTitle.Select
Application.CutCopyMode = False
ActiveChart.Location Where:=xlLocationAsNewSheet, Name:="Zellen"
ActiveWorkbook.Sheets(strTabname).Select
ActiveWindow.LargeScroll ToRight:=1
ActiveSheet.Shapes.AddChart2(227, xlLine).Select
ActiveChart.SetSourceData Source:=ActiveWorkbook.Sheets(strTabname).Range("$Z$1:$AA$" & loletzte)
ActiveChart.Location Where:=xlLocationAsNewSheet, Name:="Total"
ActiveChar

Answer 7

Hallo

Mein Problem hat sich zum Glück gelöst.
Da ich die Excel-version 2013 habe ist es anscheinend nötig das FileFormat anzugeben.
es ist allerdings komisch dass es ürsprünglich ohne die Angabe auch geklappt hat.

Hier die geänderte Schlusszeile meines Makros:
ActiveWorkbook.SaveAs Filename:=Neuer_Dateiname, FileFormat:=51