variable Chart und Worksheet ohne Makros speichern
Thomas
in dem unten stehenden Code wird eine Text-Datei in ein neues Tabellenblatt importiert und daraus in einem neuen Tabellenblatt ein Diagramm erzeugt. Anschließend wird die Mappe unter dem Tabellenblattnamen in einer neuen Mappe gespeichert und die beiden erzeugten Tabellenblätter in der alten Mappe gelöscht. In der alten Mappe ist ein Tabellenblatt Namens "Clear".
Nun hab ich folgendes Problem, ich möchte nur die beiden neu erzeugten Tabellenblätter in eine neue Mappe speichern ohne Makros und ohne das in der "alten Mappe" bestehenden Tabellenblatt "Clear".
Ich weiß nicht ob man die beiden neu erzeugten Tabellenblätter darüber ansprechen kann, dass beide ein "_" im variablen Namen haben oder gleich sagen kann alles speichern außer worksheet "clear", aber da müssten dann wieder die Makros dabei sein.
Sorry für das Durcheinander im Code, bin Anfänger.
Die betreffenden Codezeilen sind:
'Excelfile generieren
strFileName = ThisWorkbook.Path & "\" & Name & _
"_(" & Format(Date, "dd.mm.yy") & "_" & Format(Time, "mm.ss") & ")" & ".xls"
'"\" & Range("B6") & "_" & Range("B7") & "µm.xls"
wkb.SaveCopyAs Filename:=strFileName
Vielen Danke im Voraus!
Zum Verständnis der ganze Code:
Sub OpenTextFile()
Application.ScreenUpdating = False
'Textfiles auslesen
Dim varRetVal As Variant
Dim strFileName As String
ChDrive ThisWorkbook.Path
ChDir ThisWorkbook.Path
'Import
varRetVal = Application.GetOpenFilename( _
FileFilter:="Text-Dateien (*.txt), *.txt", _
Title:="Daten aus Text-Datei importieren")
If varRetVal = False Then Exit Sub
'If varRetVal "False" Or varRetVal "Falsch" Then
strFileName = varRetVal
ActiveWorkbook.Worksheets.Add
With ActiveSheet.QueryTables.Add(Connection:="Text;" + varRetVal, _
Destination:=Range("A1"))
.Name = strFileName
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1)
.TextFileDecimalSeparator = "."
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
'Tabellenblattname
'Namen+Pfad der Textdatei in Tabelle einfügen
ActiveSheet.Range("D1") = Left(strFileName, Len(strFileName) - 4)
Dim wks As Worksheet
Dim Name As String
Dim wkb As Workbook
Set wks = ActiveSheet
Set wkb = ActiveWorkbook
'Sonderzeichen ersetzen
Dim i As Long, Zelle As Range
Dim Zeichen As String
With wks
For Each Zelle In .Range("B6:B7")
For i = 1 To Len(Zelle.Text)
Zeichen = Mid(Zelle.Text, i, 1)
Select Case Zeichen
Case "/"
Zelle.Value = Left(Zelle.Text, i - 1) & " " & Right(Zelle.Text, Len(Zelle.Text) - i)
Case "\"
Zelle.Value = Left(Zelle.Text, i - 1) & " " & Right(Zelle.Text, Len(Zelle.Text) - i)
Case ":"
Zelle.Value = Left(Zelle.Text, i - 1) & " " & Right(Zelle.Text, Len(Zelle.Text) - i)
Case "*"
Zelle.Value = Left(Zelle.Text, i - 1) & " " & Right(Zelle.Text, Len(Zelle.Text) - i)
Case "?"
Zelle.Value = Left(Zelle.Text, i - 1) & " " & Right(Zelle.Text, Len(Zelle.Text) - i)
Case ">"
Zelle.Value = Left(Zelle.Text, i - 1) & " " & Right(Zelle.Text, Len(Zelle.Text) - i)
Case "'Excelfile generieren
strFileName = ThisWorkbook.Path & "\" & Name & _
"_(" & Format(Date, "dd.mm.yy") & "_" & Format(Time, "mm.ss") & ")" & ".xls"
'"\" & Range("B6") & "_" & Range("B7") & "µm.xls"
wkb.SaveCopyAs Filename:=strFileName
' Alle Register löschen bis auf Register Tabelle1
Dim T As Integer
Application.DisplayAlerts = False
For T = ActiveWorkbook.Worksheets.Count To 1 Step -1
If Worksheets(T).Name "Clear" Then _
Worksheets(T).Delete
Next T
'Charts().Delete
For P = ActiveWorkbook.Charts.Count To 1 Step -1
If Charts(P).Name "Clear" Then _
Charts(P).Delete
Next P
Application.DisplayAlerts = True
Workbooks.Open Filename:=strFileName
Set wkb = Nothing
Set wks = Nothing
Application.ScreenUpdating = True
End Sub
Gruß Thomas