Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
984to988
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
984to988
984to988
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Mit Makro doppelt unterstreichen

Mit Makro doppelt unterstreichen
20.06.2008 19:53:24
Ralf
Hallo,
ich suche ein Makro, dass wenn in Zeile B2 ein "*" kommt in Zeile e2 die Zahl doppelt unterstrichen wird. Das Makro soll die Spalte B so bis ca. Zeile 5000 durchsuchen und wenn es fündig wird immer in gleicher Zeile in Spalte E doppelt unterstreichen. Wenn so was geht würde es meine Arbeit enorm erleichtern. Ich habe nicht viel Erfahrung mit der Erstellung von Makros.
Grüße und Danke für jede Unterstützung.
Ralf

12
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Mit Makro doppelt unterstreichen
20.06.2008 20:23:00
Tino
Hallo Ralf,
teste mal diesen Code.
Sub Test() Dim A As Long Dim Bereich As Range, SBereich As Range, strAdress$ Application.ScreenUpdating = False Set Bereich = Range("B2:B10000") 'Suchbereich Bereich.Offset(0, 3).Font.Underline = xlNone For A = 1 To 10000 If A = 1 Then Set SBereich = Bereich.Find(What:="*", After:=Bereich(1), LookIn:=xlValues, LookAt:= _ xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _ , SearchFormat:=False) If Not SBereich Is Nothing Then strAdress$ = SBereich.Address SBereich.Offset(0, 3).Font.Underline = xlUnderlineStyleDouble End If Else Set SBereich = Bereich.FindNext(After:=SBereich) If SBereich.Address strAdress And Not SBereich Is Nothing Then SBereich.Offset(0, 3).Font.Underline = xlUnderlineStyleDouble Else Exit For End If End If Next A Application.ScreenUpdating = True End Sub


Gruß Tino

www.VBA-Excel.de


Anzeige
Korrektur etwas vergessen !!!!!!
20.06.2008 20:25:00
Tino

Sub Test()
Dim A As Long
Dim Bereich As Range, SBereich As Range, strAdress$
Application.ScreenUpdating = False
Set Bereich = Range("B2:B10000") 'Suchbereich
Bereich.Offset(0, 3).Font.Underline = xlNone
For A = 1 To 10000
If A = 1 Then
Set SBereich = Bereich.Find(What:="*", After:=Bereich(1), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
If Not SBereich Is Nothing Then
strAdress$ = SBereich.Address
SBereich.Offset(0, 3).Font.Underline = xlUnderlineStyleDouble
Else
Exit For
End If
Else
Set SBereich = Bereich.FindNext(After:=SBereich)
If SBereich.Address  strAdress And Not SBereich Is Nothing Then
SBereich.Offset(0, 3).Font.Underline = xlUnderlineStyleDouble
Else
Exit For
End If
End If
Next A
Application.ScreenUpdating = True
End Sub


Anzeige
AW: Korrektur etwas vergessen !!!!!!
20.06.2008 21:10:00
Tino
Hallo,
habe meinen Code nochmal getestet war wohl ein Schnellschuss, vergiss diesen ganz schnell. Sorry
Andi hat eine funktionierende alternative.
Gruß Tino

AW: so jetzt aber die Makrolösung die funktioniert
21.06.2008 08:07:57
Tino
Hallo,
jetzt finktioniert dieses Makro, habe es auch getestet ;-)

Option Explicit
Sub Test()
Dim A As Long
Dim Bereich As Range, SBereich As Range, strAdress$
Application.ScreenUpdating = False
Set Bereich = Range("B2:B10000") 'Suchbereich
Bereich.Offset(0, 3).Font.Underline = xlNone
For A = 1 To 10000
If A = 1 Then
Set SBereich = Bereich.Find(What:="~*", After:=Bereich(1), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
If Not SBereich Is Nothing Then
strAdress$ = SBereich.Address
SBereich.Offset(0, 3).Font.Underline = xlUnderlineStyleDouble
Else
Exit For
End If
Else
Set SBereich = Bereich.FindNext(After:=SBereich)
If SBereich.Address  strAdress And Not SBereich Is Nothing Then
SBereich.Offset(0, 3).Font.Underline = xlUnderlineStyleDouble
Else
Exit For
End If
End If
Next A
Application.ScreenUpdating = True
End Sub


Gruß Tino

Anzeige
AW: so jetzt aber die Makrolösung die funktioniert
21.06.2008 09:23:04
Ralf
Toll, das Makro funktioniert prima vielen vielen dank.
Kann man mit so einem Makro auch die Summen bestimmen? Immer der Zahlen oberhalb zwischen zwei "'*". Die Zahlen stehen alle in Zeile E. Da wo jetzt unterstrichen ist sollen dann die Summe stehen.

AW: so jetzt aber die Makrolösung die funktioniert
21.06.2008 16:19:00
Tino
Hallo,
mit Makro würde ich dies mittels einer Schleife machen.

Sub Test()
Dim A As Long
Dim Bereich(2) As Range
Application.ScreenUpdating = False
Columns(5).Font.Underline = xlNone
Columns(5).ClearContents
For A = Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1
If Cells(A, 2) = "*" And Bereich(1) Is Nothing Then
Set Bereich(1) = Cells(A, 2)
ElseIf Not Bereich(1) Is Nothing And Cells(A, 2) = "*" Or A = 2 Then
Set Bereich(2) = Range(CStr(Cells(A, 2).Address & ":" & Bereich(1).Address))
Bereich(1).Offset(0, 3) = Application.WorksheetFunction.Sum(Bereich(2))
Bereich(1).Offset(0, 3).Font.Underline = xlUnderlineStyleDouble
Set Bereich(1) = Nothing
Set Bereich(2) = Nothing
If A = 2 Then Exit For
A = A + 1
End If
Next A
Application.ScreenUpdating = True
End Sub


Gruß Tino

www.VBA-Excel.de


Anzeige
AW: so jetzt aber die Makrolösung die funktioniert
22.06.2008 01:08:00
Ralf
Hallo,
hab noch eine kleine Frage. Das Makro unterscheidet nicht ob "*" oder "**" und unterstreicht bei beiden. Kann man das ändern?
Grüße
Ralf

AW: so jetzt aber die Makrolösung die funktioniert
22.06.2008 02:13:35
Tino
Hallo,
so

Sub Test()
Dim A As Long
Dim Bereich(2) As Range
Application.ScreenUpdating = False
Columns(5).Font.Underline = xlNone
Columns(5).ClearContents
For A = Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1
If (Cells(A, 2) = "*" Or Cells(A, 2) = "**") And Bereich(1) Is Nothing Then
Set Bereich(1) = Cells(A, 2)
ElseIf Not Bereich(1) Is Nothing And (Cells(A, 2) = "*" Or Cells(A, 2) = "**") Or A = 2 Then
Set Bereich(2) = Range(CStr(Cells(A, 2).Address & ":" & Bereich(1).Address))
Bereich(1).Offset(0, 3) = Application.WorksheetFunction.Sum(Bereich(2))
Bereich(1).Offset(0, 3).Font.Underline = xlUnderlineStyleDouble
Set Bereich(1) = Nothing
Set Bereich(2) = Nothing
If A = 2 Then Exit For
A = A + 1
End If
Next A
Application.ScreenUpdating = True
End Sub


Gruß Tino

Anzeige
ohne Makro
20.06.2008 20:26:56
Andi
Hi,
mach das doch einfach mit bedingter Formatierung in Spalte E.
Formel (nicht Zellwert) ist:
=NICHT(ISTFEHLER(FINDEN("*";B2)))
Schönen Gruß,
Andi

Weitere Frage: Summe mit Makro
20.06.2008 22:24:18
Ralf
Danke für die schnelle Hilfe,
das mit der bedingten Formatierung ist echt klasse.
Gibt es sowas auch für die Summe? Alles wieder wie beschrieben "*" in B und in E soll die Summe gebildet werden. Immer bis zum nächsten "*" die Zwischensumme, oder geht hier nur ein Makro?
Grüße
Ralf

AW: Weitere Frage: Summe mit Makro
20.06.2008 22:30:01
Josef
Hallo Ralf,
meinst du so?
Tabelle3

 ABCDEF
1 Wert  ZS 
2 458    
3 430    
4 151    
5 *  1039 
6 438    
7 404    
8 194    
9 334    
10 457    
11 *  1827 
12 336    
13 107    
14 239    
15 278    
16 *  960 
17 431    
18 229    
19 326    
20 439    
21 *  1425 
22 174    
23 256    
24 242    
25 169    
26 210    
27 194    
28 393    
29 *  1638 
30 435    
31 367    
32 234    
33 216    
34 *  1252 
35      

Formeln der Tabelle
ZelleFormel
E2=WENN(B2="*";SUMME($B$2:B2)-SUMME($E$1:E1); "")
Excel Tabellen im Web darstellen  Excel Jeanie HTML

Gruß Sepp



Anzeige
AW: Weitere Frage: Summe mit Makro
21.06.2008 07:55:44
Ralf
Die Zahlen stehen in Spalte E daher kann ich hier keine Formel runterkopieren

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige