Frage von eao44, 104

Kann man unterstrichene/rote Zahlen in eine neue Excel Datei übernehmen so dass die unterstrichene Zahlen ebenfalls unterstrichen sind?

Ich habe eine Tabelle mit zig Werten. Manche Werte sind rot und unterstrichen und manche nicht. nun möchte ich mehrere Werte aus den verschiedenen Spalten in eine neue Excel Datei in eine Zelle übernehmen jedoch sollen die Zahlen die unterstrichen und rot sind in der neuen Excel Datei unterstrichen sein.

es sollte wie in den Bildern dargestellt werden

Hilfreichste Antwort - ausgezeichnet vom Fragesteller
von Ninombre, Community-Experte für Excel, 104

||Sub zusammen()
||Dim i As Long
||Dim pos as integer
||For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
||Cells(i, 4).Value = Cells(i, 1).Value & "/" & Cells(i, 2).Value & "/" & Cells(i, 3).Value
||pos = 1
||Cells(i, 4).Characters(Start:=pos, Length:=Len(Cells(i, 1).Value)).Font.Underline = Cells(i, 1).Font.Underline
||pos = pos + Len(Cells(i, 1).Value) + 1
||Cells(i, 4).Characters(Start:=pos, Length:=Len(Cells(i, 2).Value)).Font.Underline = Cells(i, 2).Font.Underline
||pos = pos + Len(Cells(i, 2).Value) + 1
||Cells(i, 4).Characters(Start:=pos, Length:=Len(Cells(i, 3).Value)).Font.Underline = Cells(i, 3).Font.Underline
||Next
||End Sub

Ich prüfe aber nur auf den Status unterstrichen, da zumindest in Deinem Beispiele jede rote Zahl auch unterstrichen war oder muss auch rote Zahl (ohne Unterstrich) umgewandelt werden?
Wegen der Zeilenumbrüche muss Du leider etwas nacharbeiten, da kann man hier nicht vernünftig darstellen. Überall wo ein || steht beginnt eine Zeile. Die || entfernen.

Kommentar von Ninombre ,

In meinem gebastelten Beispiel wird in der gleichen Exceltabelle zusammenkopiert. Muss das direkt in die neue Datei geschrieben werden oder kannst Du das auch manuell übertragen (Beim Einfügen > Formate beibehalten)?

Kommentar von eao44 ,

Hey Ninombre!

Danke für deine Bemühung

nein das rote muss nicht unbedingt beachtet werden. es reicht mir wenn die rote Zahl in meiner neuen excel Datei einfach nur unterstrichen wird.

funktioniert das jetzt wenn ich diesen Code in eine neue Excel Datei eingebe? oder muss es in der gleich Excel Datei sein? mein Ergebnis soll jetzt eben in einer neuen Excel datei in einer Zelle hinugefügt werden.

Kommentar von PWolff ,

Ja, das geht.

Du kannst auf eine andere Excel-Datei zugreifen über

Workbooks("Dateiname")

Und auf die einzelnen Tabellen bzw. Zellen dieser Datei mit

Workbooks("Dateiname").Worksheets("Tabellenname")

bzw.

Workbooks("Dateiname").Worksheets("Tabellenname").Cells(Zeilennr, Spaltennr)

Falls diese Datei nicht geöffnet ist, kannst du sie mit

Workbooks.Open("Pfad_zur_Datei" + "\" + "Dateiname")

öffnen. (Du solltest dir merken, ob die Datei schon geöffnet war oder nicht, und sie ggf. nachher wieder schließen:

Workbooks("Dateiname").Close

)

Kommentar von eao44 ,

Jetzt bleibt nur noch die Frage für mich, wo ich denn nun diese ganzen Codes einfügen muss 

wo muss ich nun dein Code mit deinem "Gebastelten Beispiel" eingeben und wo muss ich das mit dem workbooks usw einfügen?

Kommentar von eao44 ,

das sollte eigentlich direkt in die neue Excel Datei eingefügt werden.

würde das gehen? und wenn ja wie gehe ich da vor?

Kommentar von Ninombre ,
Das hier in die neue Datei und den Namen der Quelldatei bzw. Tabellenblatt noch anpassen:
Die Quelldatei muss geöffnet sein.
Sub zusammenkopieren()
Dim i As Long
Dim quelldatei As String
Dim quelltabelle As String
Dim zieldatei As String
Dim zieltabelle As String
quelldatei = "Quelle.xlsx"
quelltabelle = "Tabelle1"
zieldatei = ActiveWorkbook.Name
zieltabelle = ActiveSheet.Name
For i = 1 To Workbooks(quelldatei).Sheets(quelltabelle).Cells(Rows.Count, 1).End(xlUp).Row
Workbooks(zieldatei).Sheets(zieltabelle).Cells(i, 4).Value = Workbooks(quelldatei).Sheets(quelltabelle).Cells(i, 1).Value & "/" & Workbooks(quelldatei).Sheets(quelltabelle).Cells(i, 2).Value & "/" & Workbooks(quelldatei).Sheets(quelltabelle).Cells(i, 3).Value
pos = 1
Workbooks(zieldatei).Sheets(zieltabelle).Cells(i, 4).Characters(Start:=pos, Length:=Len(Workbooks(quelldatei).Sheets(quelltabelle).Cells(i, 1).Value)).Font.Underline = Workbooks(quelldatei).Sheets(quelltabelle).Cells(i, 1).Font.Underline
pos = pos + Len(Workbooks(quelldatei).Sheets(quelltabelle).Cells(i, 1).Value) + 1
Workbooks(zieldatei).Sheets(zieltabelle).Cells(i, 4).Characters(Start:=pos, Length:=Len(Workbooks(quelldatei).Sheets(quelltabelle).Cells(i, 2).Value)).Font.Underline = Workbooks(quelldatei).Sheets(quelltabelle).Cells(i, 2).Font.Underline
pos = pos + Len(Workbooks(quelldatei).Sheets(quelltabelle).Cells(i, 2).Value) + 1
Workbooks(zieldatei).Sheets(zieltabelle).Cells(i, 4).Characters(Start:=pos, Length:=Len(Workbooks(quelldatei).Sheets(quelltabelle).Cells(i, 3).Value)).Font.Underline = Workbooks(quelldatei).Sheets(quelltabelle).Cells(i, 3).Font.Underline
Next i
End Sub
Kommentar von eao44 ,

Vielen Dank! ich versuche mich mal da einzuarbeiten! hoffentlich klappts :)

Kommentar von Ninombre ,

Wenn die beiden Dateien im gleichen Verzeichnis liegen, genügt es aus:
quelldatei="Quelle.xlsx" -> quelldatei="wieauchimmerdieheisst.xlsx" zu machen
Gleiches eben mit dem Tabellenblatt, auf dem die Daten stehen.
Mehr wäre nicht zu ändern. Die Daten werden aktuell in Spalte D kopiert. Um das zu ändern, wären die Stellen anzupassen wo
cells(i,4) steht: Die Spalten werden in VBA numerisch gezählt, Spalte D also die 4. Entsprechend wäre B halt 2 etc.

Kommentar von eao44 ,

Hey, ich hab das nun versucht nun kommt aber immer eine Fehlermeldung mit " index außerhalb des gültigen bereichs."

wäre es möglich das ich dir mal meine beiden Excel Dateien schicke ?

Kommentar von eao44 ,

in der gleichen Excel Datei geht es , aber wenn ich eine neue leere Excel datei öffne und es dort einfüge funktioniert es irgendwie nicht

Kommentar von eao44 ,

Sub zusammenkopieren()Dim i As LongDim quelldatei As StringDim quelltabelle1 As StringDim quelltabelle2 As StringDim quelltabelle3 As StringDim zieldatei As StringDim zieltabelle As Stringquelldatei = "Messung.xls"quelltabelle1 = "Schuss1"quelltabelle2 = "Schuss2"quelltabelle3 = "Schuss3"zieldatei = ActiveWorkbook.Namezieltabelle = ActiveSheet.NameFor i = 22 To Workbooks(quelldatei).Sheets(quelltabelle1).Cells(Rows.Count, 1).End(xlUp).RowWorkbooks(zieldatei).Sheets(zieltabelle).Cells(i, 8).Value = Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Value & "/" & Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Value & "/" & Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 5).Valuepos = 1Workbooks(zieldatei).Sheets(zieltabelle1).Cells(i, 4).Characters(Start:=pos, Length:=Len(Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Value)).Font.Underline = Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Font.Underlinepos = pos + Len(Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Value) + 1Workbooks(zieldatei).Sheets(zieltabelle1).Cells(i, 4).Characters(Start:=pos, Length:=Len(Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Value)).Font.Underline = Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Font.Underlinepos = pos + Len(Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Value) + 1Workbooks(zieldatei).Sheets(zieltabelle).Cells(i, 4).Characters(Start:=pos, Length:=Len(Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 5).Value)).Font.Underline = Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 5).Font.UnderlineNext iEnd Sub

ich habe das nun versucht umzuschreiben da ich von der Datei auf 3 Tabellen zugreifen und zusammenfassen will...jedoch stimmt da noch irgendetwas nicht.... können sie mir hier weiterhelfen?(Die ersten Werte die eingelesen werden sollen sind in Zeile 22 , spalte 5)

Kommentar von Ninombre ,

Das Umbauen hat eigentlich ganz gut funktioniert, da waren eigentlich nur Kleinigkeiten.

Es gibt nur eine zieltabelle, manchmal war zieltabelle1 verwendet.
Beim Ermitteln der max. Anzahl von Zeilen (dieses rows.count) fragte auf die erste Spalte ab -> wenn die Daten in der 5. Spalte stehen, muss einfach statt rows.count,1 rows.count,5 verwendet werden

Eine Abweichung, dass das Ergebnis nicht in die 5. Spalte (E) geschreiben wird, sondern in Spalte H. Wenn H richtig wäre, müssten alle Bezüge auf zieltabelle.cells(i,5) auf (i,8) geändert werden.

So sollte es funktionieren:

Sub zusammenkopieren()
Dim i As Long
Dim quelldatei As String
Dim quelltabelle1 As String
Dim quelltabelle2 As String
Dim quelltabelle3 As String
Dim zieldatei As String
Dim zieltabelle As String
quelldatei = "messung.xls"
quelltabelle1 = "Schuss1"
quelltabelle2 = "Schuss2"
quelltabelle3 = "Schuss3"
zieldatei = ActiveWorkbook.name
zieltabelle = ActiveSheet.name
For i = 22 To Workbooks(quelldatei).Sheets(quelltabelle1).Cells(Rows.Count, 5).End(xlUp).RowWorkbooks(zieldatei).Sheets(zieltabelle).Cells(i, 4).Value = Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Value & "/" & Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Value & "/" & Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 5).Value
pos = 1
Workbooks(zieldatei).Sheets(zieltabelle).Cells(i, 4).Characters(Start:=pos, Length:=Len(Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Value)).Font.Underline = Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Font.Underline
pos = pos + Len(Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Value) + 1
Workbooks(zieldatei).Sheets(zieltabelle).Cells(i, 4).Characters(Start:=pos, Length:=Len(Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Value)).Font.Underline = Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Font.Underline
pos = pos + Len(Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Value) + 1Workbooks(zieldatei).Sheets(zieltabelle).Cells(i, 4).Characters(Start:=pos, Length:=Len(Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 5).Value)).Font.Underline = Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 5).Font.Underline
Next i
End Sub
Kommentar von eao44 ,

Hallo Ninombre,

ich nochmal...

ich hab das nun versucht... aber irgendwie kommt immer noch ein index fehler

https://www.dropbox.com/sh/u665qe7xf30atma/AAArNetDdcDihtvyJkwrs6Bla?dl=0

ich hab dir mal die quell datei und das ergebnis datei hier hoch geladen...

es muss hier immer der wert von Nest9 aus schuss 1, 2 und 3 zusammen gefügt werden mit einem / und eben dementsprechend unterstreichen...

ich weiß einfach nicht was ich falsch mache...

Kommentar von Ninombre ,

Da hängt die Ermittlung der letzten Zeile - ich habe jetzt auch nicht herausgefunden, warum es nicht mehr geht. Einige Dinge werden kompliziert, wenn man zwischen zwei Dateien hin- und herspringt.
In welcher Datei läuft denn der Code? Müsste eigentlich in der .xls sein, da man nur dort auch mit Makro speichern kann.

In der Variante funktioniert es bei mir: Ich hab die Zieldatei auch konkret eingegeben, damit dort kein Fehler auftritt und die Zeile, bis zu der gelesen werden soll manuell eingetragen. Auf die Schnelle funktionierte keine andere mit bekannte Variante, das zu ermitteln:

Man muss darauf achten, dass die Tabellenblätter wirklich so heißen, sonst kommen auch Indexfehler - in Deiner Datei fehlte noch das Leerzeichen in Schuss 1 etc.

Sub zusammenkopieren()
Dim i As Long
Dim quelldatei As String
Dim quelltabelle1 As String
Dim quelltabelle2 As String
Dim quelltabelle3 As String
Dim zieldatei As String
Dim zieltabelle As String
quelldatei = "file.xls"
quelltabelle1 = "Schuss 1"
quelltabelle2 = "Schuss 2"
quelltabelle3 = "Schuss 3"
zieldatei = "file.xlsx"
zieltabelle = "Tabelle1"
For i = 22 To 30
Workbooks(zieldatei).Sheets(zieltabelle).Cells(i, 4).Value = Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Value & "/" & Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Value & "/" & Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 5).Value
pos = 1
Workbooks(zieldatei).Sheets(zieltabelle).Cells(i, 4).Characters(Start:=pos, Length:=Len(Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Value)).Font.Underline = Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Font.Underline
pos = pos + Len(Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Value) + 1
Workbooks(zieldatei).Sheets(zieltabelle).Cells(i, 4).Characters(Start:=pos, Length:=Len(Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Value)).Font.Underline = Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Font.Underline
pos = pos + Len(Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Value) + 1
Workbooks(zieldatei).Sheets(zieltabelle).Cells(i, 4).Characters(Start:=pos, Length:=Len(Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 5).Value)).Font.Underline = Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 5).Font.Underline
Next i
End Sub
Kommentar von Ninombre ,

Das Makro läuft bei mir jetzt zwar, aber ich habe zwei andere Dinge festgestellt:
1. Die Werte werden in Deiner Datei (Messungen) gerundet dargestellt. Beim Kopieren wird der tatsächliche Wert übernommen
2. Die Werte sind auch nicht wirklich rot und unterstrichen im Sinne von Eigenschaft der Zelle, sondern auf Grund einer bedingten Formatieren. Damit funktionieren die Abfragen nicht.
Der bisherige Ansatz bringt nix.

Kommentar von Ninombre ,

Letzter Anlauf, ich hab sonst auch keine Ideen mehr - da muss notfalls jemand mit einem ganz anderen Ansatz ran. Wenn man zuviel reinfummelt, wird es immer verworrener.

Das hier in die Messung.xls und die Zieldatei / -tabelle überprüfen sowie die Anzahl der Zeilen, die in der For Schleife durchlaufen werden müssen:

Sub zusammenkopieren()
Dim i As Long
Dim quelldatei As String
Dim quelltabelle1 As String
Dim quelltabelle2 As String
Dim quelltabelle3 As String
Dim zieldatei As String
Dim zieltabelle As String
quelldatei = "Messung_Muster.xls"
quelltabelle1 = "Schuss 1"
quelltabelle2 = "Schuss 2"
quelltabelle3 = "Schuss 3"
zieldatei = "Ergebnis.xlsx"
zieltabelle = "Tabelle1"
For i = 22 To 30
Workbooks(zieldatei).Sheets(zieltabelle).Cells(i, 4).Value = Round(Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Value, 3) & "/" & Round(Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Value, 3) & "/" & Round(Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 5).Value, 3)
pos = 1
If Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Value > Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 2).Value + Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 3).Value Or Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Value < Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 2).Value + Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 4).Value Then Workbooks(zieldatei).Sheets(zieltabelle).Cells(i, 4).Characters(Start:=pos, Length:=Len(Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Value)).Font.Underline = 2
pos = pos + Len(Round(Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Value, 3) + 1)
If Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Value > Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 2).Value + Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 3).Value Or Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Value < Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 2).Value + Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 4).Value Then Workbooks(zieldatei).Sheets(zieltabelle).Cells(i, 4).Characters(Start:=pos, Length:=Len(Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Value)).Font.Underline = 2
pos = pos + Len(Round(Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Value, 3) + 1)
If Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 5).Value > Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 2).Value + Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 3).Value Or Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 5).Value < Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 2).Value + Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 4).Value Then Workbooks(zieldatei).Sheets(zieltabelle).Cells(i, 4).Characters(Start:=pos, Length:=Len(Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 5).Value)).Font.Underline = 2
Next i
End Sub
Kommentar von eao44 ,

Hallo! sorry das ich mich jetzt erst melde!

Ich danke dir für die Hilfe! :)

Kommentar von eao44 ,

Hallo Ninombre! ich wollte dir bescheid geben das es jetzt gut geklappt hat! vielen Dank


ich hätte da nur noch eine kleine frage, und zwar :

Wenn ich jetzt noch die Tabellen "Schuss 4" und "Schuss 5" hinzufügen möchte. bleibt dieser Teil mit

"If Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Value > Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 2).Value + Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 3).Value Or Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Value < Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 2).Value + Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 4).Value Then Workbooks(zieldatei).Sheets(zieltabelle).Cells(i-3, 21).Characters(Start:=pos, Length:=Len(Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Value)).Font.Underline = 2pos = pos + Len(Round(Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Value, 3) + 1)"


gleich? und ich müsste es nur noch 2 mal nach unten kopieren und füge dementsprechend noch 2 quelltabellen hinzu, oder muss man da sonst noch irgendwas umändern?


Dieser bereich ist mir klar was ich hinzufügen muss:

Workbooks(zieldatei).Sheets(zieltabelle).Cells(i, 21).Value = Round(Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Value, 3) & " / " & Round(Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Value, 3) & " / " & Round(Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 5).Value, 3)

Kommentar von Ninombre ,

Wenn Schuss 4 und 5 auch so aufgebaut sind, dann reichen zwei neue Zeilen, in denen Du die Tabelle entsprechend änderst.
Mit der Formel wird die bedingte Formatierung nachgestellt, also geprüft ob der Wert innerhalb der Toleranzgrenzen liegt oder eben unterstrichen wird. Das erfolgt isoliert für jede Tabelle, daher zwei neue Einträge.

Zu diesen Zeilen brauchst Du noch die Definition der neuen Variablen quelltabelle 4 und 5, sowie die Zuordnung der Werte, also quelltabelle 4 = "Schuss 4".
Bei neuem Erkenntnisstand wäre es eleganter gewesen, das Unterstreichen auch in einer For-Next Schleife zu behandeln, dann wäre das hinzufügen von neuen Tabellen weniger aufwändig gewesen.

Kommentar von eao44 ,

Achso ok ,

das ist nicht schlimm, denn es wird Maximal nur 5 Schüsse geben :)

dein Code ist also ideal

nun hätte ich nur noch eine kleine frage, und zwar ,

http://www.bilder-upload.eu/show.php?file=e22d66-1449566215.jpg

wieso wird es hier bei mir so unsauber unterstrichen? Bei der 3. Zeile müsste der letzte wert auch noch komplett unterstrichen werden und bei der letzten sollte das in der mitte nicht unterstrichen sein...

Kommentar von Ninombre ,

An sich müsste man es mal komplett neu schreiben, das nachträgliche Einfügen macht die Sache sehr unübersichtlich. Der Fehler ist, dass die Zahlen gerundet dargestellt werden. Könnte man lösen, wenn an den richtigen Stellen mit text statt value gearbeitet wird. Zum Reinflicken ist aber folgendes einfacher:

In die drei Endloszeilen (bzw. jetzt 5) noch die fett markierten dazu

Length:=Len(Round(Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Value, 4))).Font.Underline = 2

Ich hoffe so passt es jetzt.

Kommentar von eao44 ,

Es ist besser, jedoch noch nicht ganz korrekt.

wo müsste ich denn das mit text statt value umändern?

Kommentar von Ninombre ,

n geänderter Form der Teil für die For-Schleife:

For i = 22 To 30
Workbooks(zieldatei).Sheets(zieltabelle).Cells(i, 4).Value = Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Text & "/" & Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Text & "/" & Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 5).Text
pos = 1
If Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Value > Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 2).Value + Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 3).Value Or Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Value < Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 2).Value + Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 4).Value Then Workbooks(zieldatei).Sheets(zieltabelle).Cells(i, 4).Characters(Start:=pos, Length:=Len(Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Text)).Font.Underline = 2
pos = pos + Len(Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Text) + 1
If Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Value > Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 2).Value + Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 3).Value Or Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Value < Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 2).Value + Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 4).Value Then Workbooks(zieldatei).Sheets(zieltabelle).Cells(i, 4).Characters(Start:=pos, Length:=Len(Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Text)).Font.Underline = 2
pos = pos + Len(Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Text) + 1
If Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 5).Value > Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 2).Value + Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 3).Value Or Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 5).Value < Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 2).Value + Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 4).Value Then Workbooks(zieldatei).Sheets(zieltabelle).Cells(i, 4).Characters(Start:=pos, Length:=Len(Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 5).Text)).Font.Underline = 2
Next i

Das Zusammenhängen der Werte mit / ist einfacher mit Text, weil nur der angezeigte Text genommen wird, man also nicht noch mals runden muss beim Kopieren. Gleiches beim Ermitteln der POS und der Length für das Unterstreichen. Der Rest muss value bleiben, damit die Vergleiche richtig erfolgen.

Kommentar von eao44 ,

Hey Ninombre!

jetzt hat alles super geklappt genau so habe ich es mir vorgestellt!

Vielen lieben Dank!

Antwort
von xGlumi, 94

..... war den VBA Code dafür am schreiben, aber Excel ist abgestürzt und ich habe nicht gespeichert -.- (Wiederherstellungsdatei? Nix :/)

Nochmal schreiben wollte ich das jetzt nicht unbedingt,
hier einpaar Stichpunkte zur Lösung:

Arbeite mit folgenden Objekten:

  • Listen: Workbooks, Worksheets
  • Objekte: Workbook, Range, Worksheet

Um den ausgewählten bereich aus deinem aktuellen Workbook zu bekommen:

Dim rng as Range
Set rng = Selection

Ein anderes Workbook wählst du mit:

"Workbooks(INDEX)" aus.

Das gleiche gilt für Worksheets:

"Workbooks(INDEX).Worksheets(INDEX)"

Hoffe ich hab hier soweit alles zusammengeffast was man dafür braucht, ansonsten meld dich einfach nochmal :)

MFG xGlumi

Kommentar von eao44 ,

Hey, Vielen Dank für deine bemühung,

leider sagt mir das ganze gar nichts, bin relativ neu in sachen Excel.

vlt kannst du mir ja kurz schritt für schritt sagen wie ich vorgehen soll? 

grüße

Kommentar von xGlumi ,

Lass dir in einer Schleife alle Workbooks(und deren Index) ausgeben.

Dann fragst du den gewünschten Index ab(Damit das Makro weiss, welches das Workbook ist wo der neue Text sein soll)

Jetzt gehst du die Selection aus deinem ersten Workbook durch (Schleife: For each Object in Range), und speicherst dir diese am besten direkt in einer Variable zwischen.

(Oder du fügst den Text direkt in das andere Dokument ein, und formatierst den eingefügten Teil direkt(wie PWolff unten schon sagte))

MFG xGlumi

Antwort
von PWolff, 89

Teile eines Textes in einer Zelle kann man bei Excel nur per Makro formatieren. Soweit ich weiß, gilt dies auch für die neueren Versionen.

Die Characters()-Methode der jeweiligen Zelle liefert ein Charakters-Objekt zurück, dessen Font-Objekt man bearbeiten kann.

Kommentar von PWolff ,

In den Kommentaren zu anderen Antworten lese ich, dass du noch nicht viel Erfahrung mit Excel hast.

Das zugehörige Makro müsste etwas in dieser Art enthalten:

    For zeile = 1 to Range("Tabelle1!A:A").SpecialCells(xlCellTypeLastCell).Row
Me.Cells(zeile, 3).Text = ""
For spalte = 1 to 3 'Spalten A bis C
If spalte > 1 Then
Me.Cells(zeile, 3).Text = Me.Cells(zeile, 3).Text + "/"
End If
Me.Cells(zeile, 3).Text = Me.Cells(zeile, 3).Text + _
Worksheets("Tabelle1").Cells(zeile, spalte). Text
Next spalte '= 1 to 3 'Spalten A bis C

aktuelleZeichenposition = 1
For spalte = 1 to 3 'Spalten A bis C
If spalte > 1 Then aktuelleZeichenposition = aktuelleZeichenposition + Len("/")
Me.Cells(zeile, 3).Characters(aktuelleZeichenposition, Len(Worksheets("Tabelle1").Cells(zeile, spalte).Text)).Font = _
Worksheets("Tabelle1").Cells(zeile, spalte).Font
Next spalte '= 1 to 3 'Spalten A bis C
Next zeile '= 1 to Range("Tabelle1!A:A").SpecialCells(xlCellTypeLastCell).Row
Kommentar von PWolff ,

Es kann sein, dass die Font-Eigenschaft schreibgeschützt ist. (Ist sogar ziemlich wahrscheinlich.)

Dann müsstest du die relevanten Eigenschaften des Font-Objekts übertragen.

Kommentar von eao44 ,

Vielen Danke für Ihre bemühung.

Kann ich diesen Code nun gleichin eine neue Excel Datei einfügen, so dass er auf die Zahlen meiner Tabelle zugreift und diese dann in eine Zelle in meiner neuen Excel datei einfügt?

Wenn ja, was müsste ich an Ihren Code noch ändern?

Kommentar von PWolff ,
Worksheets("Tabelle1")

ersetzen durch

Workbooks("Dateiname").Worksheets("Tabellenname")

(siehe mein Kommentar bei der Antwort von Ninombre)

Kommentar von eao44 ,

Vielen Dank! ich versuche es mal

Kommentar von eao44 ,

Sub zusammenkopieren()Dim i As LongDim quelldatei As StringDim quelltabelle1 As StringDim quelltabelle2 As StringDim quelltabelle3 As StringDim zieldatei As StringDim zieltabelle As Stringquelldatei = "Messung.xls"quelltabelle1 = "Schuss1"quelltabelle2 = "Schuss2"quelltabelle3 = "Schuss3"zieldatei = ActiveWorkbook.Namezieltabelle = ActiveSheet.NameFor i = 22 To Workbooks(quelldatei).Sheets(quelltabelle1).Cells(Rows.Count, 1).End(xlUp).RowWorkbooks(zieldatei).Sheets(zieltabelle).Cells(i, 8).Value = Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Value & "/" & Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Value & "/" & Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 5).Valuepos = 1Workbooks(zieldatei).Sheets(zieltabelle1).Cells(i, 4).Characters(Start:=pos, Length:=Len(Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Value)).Font.Underline = Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Font.Underlinepos = pos + Len(Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Value) + 1Workbooks(zieldatei).Sheets(zieltabelle1).Cells(i, 4).Characters(Start:=pos, Length:=Len(Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Value)).Font.Underline = Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Font.Underlinepos = pos + Len(Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Value) + 1Workbooks(zieldatei).Sheets(zieltabelle).Cells(i, 4).Characters(Start:=pos, Length:=Len(Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 5).Value)).Font.Underline = Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 5).Font.UnderlineNext iEnd Sub


ich habe das nun versucht umzuschreiben da ich von der Datei auf 3 Tabellen zugreifen und zusammenfassen will...jedoch stimmt da noch irgendetwas nicht.... können sie mir hier weiterhelfen? (Die ersten Werte die eingelesen werden sollen sind in Zeile 22 , spalte 5)

Kommentar von eao44 ,

Entschuldigung wegen dem Format aber ich weiß nicht wie ich wie Sie als Code hier rein schreiben kann :D

Kommentar von PWolff ,

Kein Problem - das ist auch nicht einfach mit dem Code hier.

Ich mache es meistens so, dass ich den Code in eine simple Textverarbeitung wie Notepad oder Leafpad kopiere und an den Anfang jeder Zeile ein Zeichen setze, das im Quelltext möglichst nicht vorkommt. Darauf kopiere ich den Quelltext in das Eingabefeld dieses Forums, danach suche ich nach diesem Zeichen und setze einen Zeilenumbruch davor und zuletzt lösche ich dieses besondere Zeichen.

Kommentar von PWolff ,

a) 

quelltabelle1 = "Schuss1"

Das .xls bzw. .xlsx muss soweit ich weiß mit in den Dateinamen

b) für den Text als solchen steht da

Workbooks(zieldatei).Sheets(zieltabelle).Cells(i, 8).Value = ...

Im folgenden wird aber zurückgegriffen auf

Workbooks(zieldatei).Sheets(zieltabelle1).Cells(i, 4)

c) Der Code wird übersichtlicher, wenn die Zeilen kürzer werden - ich hab die Zellbezeichnungen mal in Variablen gesteckt:

  const trenner = "/"
dim Zielzelle as Range, Quellzelle1 as Range, Quellzelle2 as Range, Quellzelle3 as Range
dim Quelltext1 as string, Quelltext2 as string, Quelltext3 as string

for i = 22 To Workbooks(quelldatei).Sheets(quelltabelle1).Cells(Rows.Count, 1).End(xlUp).Row

set zielzelle = Workbooks(zieldatei).Sheets(zieltabelle).Cells(i, 8)

set quellzelle1 = Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5): quelltext1 = quellzelle1.Text
set quellzelle2 = Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5): quelltext2 = quellzelle2.Text
set quellzelle3 = Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 5): quelltext3 = quellzelle3.Text

set zielzelle2 = Workbooks(zieldatei).Sheets(zieltabelle1).Cells(i, 4)

zielzelle2.Text = quellzelle1.Text + trenner + quellzelle2.Text + trenner + quellzelle3.Text

pos = 1 : lg = len(quelltext1)
zielzelle.Characters(pos, lg).Font.Underline = quellzelle1.Font.Underline
pos = pos + lg + len(trenner): lg = len(quelltext2)
zielzelle.Characters(pos, lg).Font.Underline = quellzelle2.Font.Underline
pos = pos + lg + len(trenner): lg = len(quelltext3)
zielzelle.Characters(pos, lg).Font.Underline = quellzelle3.Font.Underline

next
Kommentar von eao44 ,

Wenn ich den Code nun in meine Tabelle einfüge funktioniert es irgendwie nicht... 

ich hab hier mal die Excel Dateien hochgeladen

https://www.dropbox.com/sh/u665qe7xf30atma/AAArNetDdcDihtvyJkwrs6Bla?dl=0

vlt können sie mir sagen was ich falsch mache....

es muss hier immer der wert von Nest9 aus schuss 1, 2 und 3 zusammen gefügt werden mit einem / und eben dementsprechend unterstreichen...

Kommentar von Ninombre ,

@PWolff: Falls Du Dich auch noch mal daran versuchen willst: Es ist zusätzlich das Thema gerundete Werte kopieren und keine echte Unterstreichung, sondern bedingte Formatierung zu berücksichtigen.

Keine passende Antwort gefunden?

Fragen Sie die Community