Vba Trendlinienformel nutzbar machen
05.04.2016 08:50:26
Johannes
ich beschäftige mich jetzt seit einigen Tagen mit VBA und komme leider gerade nicht mehr weiter.....
Hintergrund:
Ich importiere Daten, sortiere mir aus den importierten Daten die für meine Zwecke benötigen Teile heraus, erzeuge mir ein XY-Diagramm, erzeuge mir eine Trendlinie Polynomisch 6 Grad, ersetzte Formelteile so, dass sie theoretisch nutzbar werden und kopiere sie anschließend in meine Zielzelle.
Soweit alles gut, das einzige was nicht funktioniert ist das "Leerzeichen" vor dem "=" weg zu machen, wenn ich dies mache kommt ein Fehler (1004, Anwendungs- oder objektdefinierter Fehler)....
Wenn das Leerzeichen verbleibt wird die Formel wie gewünscht in die Zelle kopiert (als Text oÄ.), ich kann händig das Leerzeichen wegmachen und mit Enter bestätigen und es funktioniert. Auch durch markieren des Bereiches und die Funktion "suchen und ersetzten" funktioniert es. Wenn ich dies mit dem Macrorecorder aufzeichen jedoch wieder nicht, bzw. es passiert nichts...
Anbei hänge ich meinen Code an, die Datei kann ich aufgrund der Daten leider nicht zur Verfügung stellen...
Ich bin wie erwähnt Leihe deswegen ist der Code bestimmt nicht so dolle :)
Aber ich hoffe sehr das ihr mir bei meinem Problem weiterhelfen könnt!
Wie erwähnt geht es darum die Formel in der Zielzelle nutzbar zu machen.
Viele Grüße
Johannes
---------------------------------------------------------------------------
Sub csv_Import()
' csv_Import Makro
Cells.Select
Selection.ClearContents
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Neue Datei einlesen").ChartObjects.Delete
Application.DisplayAlerts = True
On Error GoTo 0
'Variablen deklarieren-------------------------------------------------------------------------- _
_
Dim Dateiname As Variant
Dim suche1 As Integer
Dim suche2 As Integer
Dim suche3 As Integer
Dim bereich1 As Integer
Dim a As Integer
Dim b As Integer
Dim c As Integer
Dim for_i As Integer
Dim ax As Integer
Dim ay As Integer
Dim strFormel1 As String
Dim strFormel2 As String
'Datei importieren------------------------------------------------------------------------------ _
_
Dateiname = Application.GetOpenFilename("Alle Dateien,*.*")
If Dateiname = False Then Exit Sub
' Import der csv-Datei
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & Dateiname, Destination:=Range("$A$1") _
_
)
.Name = "Materialdaten"
.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 = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1)
.TextFileDecimalSeparator = "."
.TextFileThousandsSeparator = ","
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
'Suchen nach Schlüsselworten-------------------------------------------------------------------- _
_
suche1 = Application.Match("!--- Wõrmeleitfõhigkeit W/m? K", Range("A1:A300"), 0) + 5
suche2 = Application.Match("kxx", Range("B1:B300"), 0)
suche3 = Cells(suche2, 2).End(xlDown).Row
'Sheets("Neue Datei einlesen").Range("M1").Value = suche1
'Sheets("Neue Datei einlesen").Range("M2").Value = suche2
'Sheets("Neue Datei einlesen").Range("M3").Value = suche3
'Temperaturen kopieren und transponieren------------------------------------------------------
a = suche1 - 1
Sheets("Neue Datei einlesen").Cells(a, 14).Value = "Temperatur"
a = suche1
For for_i = 0 To suche2 - 2 - suche1
a = suche1 + for_i
ax = suche1 + 6 * for_i
Range(Cells(a, 3), Cells(a, 8)).Select
Selection.Copy
Cells(ax, 14).Select
Selection.PasteSpecial Transpose:=True
Next for_i
'Wärmeleitfähigkeiten kopieren und transponieren------------------------------------------------ _
_
a = suche1 - 1
Sheets("Neue Datei einlesen").Cells(a, 15).Value = "Wärmeleitfähigkeit"
a = suche1
For for_i = 0 To suche2 - 2 - suche1
b = suche2 + for_i
ax = a + 6 * for_i
Range(Cells(b, 5), Cells(b, 10)).Select
Selection.Copy
Cells(ax, 15).Select
Selection.PasteSpecial Transpose:=True
Next for_i
'Diagramm erzeugen------------------------------------------------------------------------------ _
_
ay = suche1
ax = Cells(suche1, 15).End(xlDown).Row
Range(Cells(ay, 14), Cells(ax, 15)).Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlXYScatter
ActiveChart.SetSourceData Source:=Range(Cells(ay, 14), Cells(ax, 15))
ActiveChart.SeriesCollection(1).Select
ActiveChart.SeriesCollection(1).Trendlines.Add
ActiveChart.SeriesCollection(1).Trendlines(1).Select
With Selection
.Type = xlPolynomial
.Order = 6
End With
Selection.DisplayEquation = True
ActiveChart.SeriesCollection(1).Select
ActiveChart.SeriesCollection(1).Trendlines(1).DataLabel.Select
Selection.NumberFormat = "#0,.E+00"
Selection.NumberFormat = "#0,.0000000000000000000000E+00"
ActiveChart.SeriesCollection(1).Trendlines(1).DataLabel.Select 'wichtig für Formel _
_
auslesen
strFormel1 = ActiveChart.SeriesCollection(1).Trendlines(1).DataLabel.Text 'wichtig für Formel _
_
auslesen
strFormel2 = ActiveChart.SeriesCollection(1).Trendlines(1).DataLabel.Text 'wichtig für Formel _
_
auslesen
'Formel in Zelle kopieren und Zeichen anpassen-------------------------------------------------- _
_
a = suche1 - 1
Sheets("Neue Datei einlesen").Cells(a, 16).Value = "Neue Wärmeleitfähigkeit"
For for_i = 0 To ax - suche1
c = suche1 + for_i
strFormel2 = Replace(Replace(Replace(Replace(strFormel1, "y", ""), "E", "*10^"), "x", "*x^") _
_
, ",000", "0,000")
strFormel2 = Replace(strFormel2, "x", Cells(c, "N"))
strFormel2 = Replace(strFormel2, "^ +", "+")
strFormel2 = Replace(Replace(strFormel2, " ", ""), "=", " =")
'strFormel2 = Replace(strFormel2, " =", "=")
Sheets("Neue Datei einlesen").Cells(c, 16) = strFormel2
Next for_i
Range(Cells(ay, 16), Cells(c, 16)).Select
Selection.Replace What:=" =", Replacement:="=", LookAt:=xlPart, SearchOrder:=xlByRows, _
MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End Sub
----------------------------------------------------------------------------------