Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1464to1468
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Excel will als Unicode abspeichern

Excel will als Unicode abspeichern
30.12.2015 21:24:01
PaulB.
Hallo
Dies ist mein erstes Posting und startet leider gleich mit einem Problem.
Ich bin ziemlich neu im Bereich VBA.
Aber ich bin dabei nach und nach zu lernen.
Leider habe ich hier ein Problem wo ich nicht weiterkomme.
Das unten stehende Makro lief wie gewünscht.
Im Makro werden Daten aus einer Text-Datei 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.
Ähnliches geschieht für das Blatt "Total"
Dann wird man gefragt ob man die Arbeitsmappe unter einem aus den Eingangsdatei abgeleitetem Namen als XLSX abspeichern will.
Wenn man die Arbeitsmappe dann schliessen will - wird man nochmal aufgefordert abzuspeichern. (so soll das auch sein, und das funzte ursprünglich auch)
Wählt man hier "Nein" kommt man nicht raus.
Wählt man "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 korrekt (inkl.abspeichern) durch.
Dann habe ich aber in beiden Charts ("Zellen" und "Total")die Legende eingefügt sowie als Category- und Value-achse die Wörter "Minutes" und "Volt" eingefügt.
Ab diesem Moment hatte ich das Problem :-((
Im Makro steht das zu Begin der unteren Hälfte.
Ich sehe leider nicht wo hier der Hase im Pfeffer liegt.
Ich würde mich freuen wenn jemand mir einen kleinen Schubs geben könnte.
Ansonsten wünsche 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)
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)
' ab dieser Aktion trat das Problem auf
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"
ActiveChart.Axes(xlCategory, xlPrimary).HasTitle = True
ActiveChart.Axes(xlCategory).AxisTitle.Select
ActiveChart.Axes(xlCategory, xlPrimary).AxisTitle.Text = "Minutes"
Selection.Format.TextFrame2.TextRange.Characters.Text = "Minutes"
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"
ActiveWorkbook.Sheets(strTabname).Select
ActiveWorkbook.Sheets(strTabname).Move Before:=Sheets(1)
Range("AB258").Select
'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

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Excel will als Unicode abspeichern
30.12.2015 21:38:53
Sepp
Hallo Paul,
hab den Code mal ein wenig bereinigt, sehe aber keinen Fehler, außer, dass du das Fileformat nicht angibst, das ist aber ab xl2013 notwendig!
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

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)


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").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("B1").FormulaR1C1 = "Zelle 1"
Range("C1").FormulaR1C1 = "Zelle 2"
Range("B1:C1").AutoFill Destination:=Range("B1:Y1"), Type:=xlFillDefault
Range("Z1").FormulaR1C1 = "Total"
Columns("Z:Z").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("A:A").Copy Columns("Z:Z")
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)

' ab dieser Aktion trat das Problem auf
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"
ActiveChart.Axes(xlCategory, xlPrimary).HasTitle = True
ActiveChart.Axes(xlCategory).AxisTitle.Select
ActiveChart.Axes(xlCategory, xlPrimary).AxisTitle.Text = "Minutes"
Selection.Format.TextFrame2.TextRange.Characters.Text = "Minutes"

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"

ActiveWorkbook.Sheets(strTabname).Move Before:=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
Else
  'aktive Arbeitsmappe speichern
  ActiveWorkbook.SaveAs Filename:=Neuer_Dateiname, FileFormat:=51
End If
End Sub

Gruß Sepp

Anzeige
AW: Excel will als Unicode abspeichern
30.12.2015 22:10:41
PaulB.
Hallo Sepp
Vielen Dank für deine schnelle Antwort.
Ja, ich habe xl2013
Ich nehme an dass es sich mit deinem Zusatz:FileFormat:=51 um das Format für xl2013 (= eigentlich klar)
Morgen kann ich erst versuchen ob das mein Problem behebt.
Komisch ist allerdings dass alles trotzdem funktionierte bis ich die Axis-title anwählte und dann auch die Werte Volt resp. Minutes eingab.
Ich hatte heute Nachmittag diese Zeilen im Makro gelöscht. Uns dann klappte das abspeichern wieder.
Deshalb dachte ich dass das Problem daher kommt.
Aber was solls ? Ich werde morgen dein Vorschlag mal ausprobieren.
Das Makro werden einige Kollegen auch verwenden (wollen).
Ich bin mir nicht sicher ob die alle XL2013 haben.
Falls die das nicht haben - muss bei denen der Zusatz: FileFormat:=51 wieder raus ?
Auf jeden Fall, grossen Dank an Dich und meine besten Wünsche für das neue Jahr.

Anzeige
AW: Excel will als Unicode abspeichern
30.12.2015 22:19:15
Sepp
Hallo Matthias,
man kann auch auslesen, welche Version läuft und danach das Fileformat festlegen.
Gruß Sepp

Mit Versionsabfrage
30.12.2015 22:24:28
Sepp
Hallo Matthias,
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

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
Dim strExt As String, lngFormat As Long

''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)
'
'
'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").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
'Range("B1").FormulaR1C1 = "Zelle 1"
'Range("C1").FormulaR1C1 = "Zelle 2"
'Range("B1:C1").AutoFill Destination:=Range("B1:Y1"), Type:=xlFillDefault
'Range("Z1").FormulaR1C1 = "Total"
'Columns("Z:Z").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'Columns("A:A").Copy Columns("Z:Z")
'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)
'
'' ab dieser Aktion trat das Problem auf
'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
'ActiveSheet.Shapes.AddChart2(227, xlLine).Select
'ActiveChart.SetSourceData Source:=ActiveWorkbook.Sheets(strTabname).Range("$Z$1:$AA$" & _
  ' loletzte)

'ActiveChart.Location Where:=xlLocationAsNewSheet, Name:="Total"
'ActiveChart.Axes(xlCategory, xlPrimary).HasTitle = True
'ActiveChart.Axes(xlCategory).AxisTitle.Select
'ActiveChart.Axes(xlCategory, xlPrimary).AxisTitle.Text = "Minutes"
'Selection.Format.TextFrame2.TextRange.Characters.Text = "Minutes"
'
'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"
'
'ActiveWorkbook.Sheets(strTabname).Move Before:=Sheets(1)

Call getFormatAndExtesion(ActiveWorkbook, lngFormat, strExt)

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

Private Sub getFormatAndExtesion(ByRef WKBook As Workbook, ByRef FileFormatNum As Long, ByRef FileExtStr As String)

With WKBook
  If Val(Application.Version) < 12 Then
    'Excel 97-2003
    FileExtStr = ".xls": FileFormatNum = -4143
  Else
    'Excel 2007-2016
    Select Case .FileFormat
      Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
      Case 52:
        If .HasVBProject Then
          FileExtStr = ".xlsm": FileFormatNum = 52
        Else
          FileExtStr = ".xlsx": FileFormatNum = 51
        End If
      Case 56: FileExtStr = ".xls": FileFormatNum = 56
      Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
    End Select
  End If
End With

End Sub

Gruß Sepp

Anzeige
Der richtige Code! ;-))
30.12.2015 22:25:10
Sepp
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

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
Dim strExt As String, lngFormat As Long

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


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").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("B1").FormulaR1C1 = "Zelle 1"
Range("C1").FormulaR1C1 = "Zelle 2"
Range("B1:C1").AutoFill Destination:=Range("B1:Y1"), Type:=xlFillDefault
Range("Z1").FormulaR1C1 = "Total"
Columns("Z:Z").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("A:A").Copy Columns("Z:Z")
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)

' ab dieser Aktion trat das Problem auf
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
ActiveSheet.Shapes.AddChart2(227, xlLine).Select
ActiveChart.SetSourceData Source:=ActiveWorkbook.Sheets(strTabname).Range("$Z$1:$AA$" & _
  loletzte)
ActiveChart.Location Where:=xlLocationAsNewSheet, Name:="Total"
ActiveChart.Axes(xlCategory, xlPrimary).HasTitle = True
ActiveChart.Axes(xlCategory).AxisTitle.Select
ActiveChart.Axes(xlCategory, xlPrimary).AxisTitle.Text = "Minutes"
Selection.Format.TextFrame2.TextRange.Characters.Text = "Minutes"

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"

ActiveWorkbook.Sheets(strTabname).Move Before:=Sheets(1)

Call getFormatAndExtesion(ActiveWorkbook, lngFormat, strExt)

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

Private Sub getFormatAndExtesion(ByRef WKBook As Workbook, ByRef FileFormatNum As Long, ByRef FileExtStr As String)

With WKBook
  If Val(Application.Version) < 12 Then
    'Excel 97-2003
    FileExtStr = ".xls": FileFormatNum = -4143
  Else
    'Excel 2007-2016
    Select Case .FileFormat
      Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
      Case 52:
        If .HasVBProject Then
          FileExtStr = ".xlsm": FileFormatNum = 52
        Else
          FileExtStr = ".xlsx": FileFormatNum = 51
        End If
      Case 56: FileExtStr = ".xls": FileFormatNum = 56
      Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
    End Select
  End If
End With

End Sub

Gruß Sepp

Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige