Bereich zwischen dem Start-und Endwert markieren

Forumthread: Bereich zwischen dem Start-und Endwert markieren

23.11.2017 11:03:08

Christian

Hallo zusammen,
ich bräuchte Hilfe zu folgender Sachlage:
in der nachfolgend gezeigten Tabelle möchte ich gerne mit einem Makro in Spalte C, die Bereiche zwischen den Startwerten 1 in Spalte A und den Endwerten 1 in Spalte B mit 1ern auffüllen.
Zusätzlich soll das Makro abbrechen, wenn in Spalte A kein Wert mehr steht.
Meine Kenntnisse in VBA sind gering und ich muss gestehen, dass ich für diese Aufgabe noch nicht einmal einen Ansatz habe.
Ich wäre für jede Hilfe dankbar!
Beste Grüße
Userbild

Christian

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Teste mal...

23.11.2017 11:24:02

Michael
Formellösung

23.11.2017 11:26:49

ChrisL
AW: Bereich zwischen dem Start-und Endwert markieren

23.11.2017 11:38:10

UweD
AW: Bereich zwischen dem Start-und Endwert markieren

23.11.2017 12:35:47

Christian
also zu und geschlossen ... (owT)

23.11.2017 14:17:15

EtoPHG

Teste mal...

23.11.2017 11:24:02

Michael

folgenden Code, Christian,
...dem allerdings die Annahme/Bedingung zu Grunde liegt, dass die Start- und End-Zellen strikt paarweise auftreten, es also nicht mehr Start- als Ende-Zellen gibt oder vice versa.

Sub a()
Dim Wb As Workbook: Set Wb = ThisWorkbook
Dim Ws As Worksheet: Set Ws = Wb.Worksheets("Tabelle1")
Dim r As Range, f As Range, ff$, a(), b(), i&
Application.ScreenUpdating = False
With Ws
Set r = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
Set f = r.Find(what:="1", LookIn:=xlValues, lookat:=xlWhole)
ReDim a(1 To r.Cells.Count)
If f Is Nothing Then
MsgBox "Kein Starteintrag gefunden!", vbCritical, "Abbruch"
Exit Sub
Else:
ff = f.Address
Do
i = i + 1
a(i) = f.Address
Set f = r.FindNext(f)
Loop While Not f Is Nothing And f.Address  ff
ReDim Preserve a(1 To i): i = 0
Set f = Nothing: Set r = Nothing
End If
Set r = .Range("B1:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
Set f = r.Find(what:="1", LookIn:=xlValues, lookat:=xlWhole)
ReDim b(1 To r.Cells.Count)
If f Is Nothing Then
MsgBox "Kein Endeintrag gefunden!", vbCritical, "Abbruch"
Exit Sub
Else:
ff = f.Address
Do
i = i + 1
b(i) = f.Address
Set f = r.FindNext(f)
Loop While Not f Is Nothing And f.Address  ff
ReDim Preserve b(1 To i): i = 0
Set f = Nothing: Set r = Nothing
End If
For i = LBound(a) To UBound(a)
Set r = .Range(.Range(a(i)), .Range(b(i)))
r.Offset(, 2).Resize(r.Rows.Count, 1).Value = 1
Next i
End With
Set Wb = Nothing: Set Ws = Nothing: Set r = Nothing
Erase a: Erase b
End Sub

LG
Michael

Formellösung

23.11.2017 11:26:49

ChrisL

Hi Christian
Hier eine Idee für eine Formellösung, Zelle C2 folgende:
=WENN(ODER(A2=1;UND(C1=1;B11));1;"")
cu
Chris

AW: Bereich zwischen dem Start-und Endwert markieren

23.11.2017 11:38:10

UweD

Noch eine Variante

Tabelle1

	A	B	C
1	Start	Ende	Dauer
2	1	0	1
3	0	0	1
4	0	0	1
5	0	0	1
6	0	0	1
7	0	0	1
8	0	0	1
9	0	0	1
10	0	1	1
11	0	0
12	0	0
13	0	0
14	0	0
15	1	0	1
16	0	0	1
17	0	0	1
18	0	0	1
19	0	0	1
20	0	0	1
21	0	0	1
22	0	0	1
23	0	0	1
24	0	0	1
25	0	0	1
26	0	0	1
27	0	1	1
28	0	0
29	0	0
30	0	0

verwendete Formeln
Zelle	Formel	Bereich	N/A
C2:C30	=WENN(SUMME($A$2:A2)-SUMME($B$1:B1)>0;1;"")

http://excel-inn.de/dateien/vba_beispiele/tabellenanzeige_in_html_addin.zip

http://Hajo-Excel.de/tools.htm

XHTML-Tabelle zur Darstellung in Foren, einschl. der neuen Funktionen ab Version 2007

Add-In-Version 21.10 einschl. 64 Bit

LG UweD

AW: Bereich zwischen dem Start-und Endwert markieren

23.11.2017 12:35:47

Christian

Vielen herzlich Dank!
Alle drei Varianten funktionieren einwandfrei!
Gruß Christian

also zu und geschlossen ... (owT)

23.11.2017 14:17:15

EtoPHG

Beliebteste Forumthreads (12 Monate)

Bereich zwischen dem Start-und Endwert markieren

Forumthread: Bereich zwischen dem Start-und Endwert markieren

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

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread