Automatisiertes Einfügen von Zeilen anhand von Faktoren

[atilla]

Hallo,

hier eine neue angepasste Lösung:

Code:

Sub ordne_um_mit_verbundenen_Zellen2()
 Dim i As Long, j As Long, k As Long
 Dim lngZ As Long
 Dim lngAnzahl As Long, lngEinheiten As Long
 Dim strgAddressen As String
 Dim varA, varZiel
 
 With Sheets("Tabelle1")
   lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row
   varA = .Range("A6:K" & lngZ)                        'Bereich, der eingelesen werden soll Hier A6:K bis letzte belegte Zeile in A
   lngEinheiten = Application.Sum(.Range("D6:D" & lngZ))
 End With
 
 With Sheets("Tabelle3")
   .Columns("D").MergeCells = False
   lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
   .Range("A2").Resize(lngZ - 1, UBound(varA, 2)).ClearContents
   varZiel = .Range("A2").Resize(lngEinheiten, UBound(varA, 2))
   
   For i = LBound(varA) To UBound(varA)
     If varA(i, 4) > 1 Then strgAddressen = strgAddressen & ", " & .Range(.Cells(k + 2, 4), .Cells(k + varA(i, 4) + 1, 4)).Address
     varZiel(k + 1, 4) = varA(i, 4)
     For j = 1 To varA(i, 4)
       For n = 1 To UBound(varA, 2)
         varZiel(k + j, n) = varA(i, n)
         If n = 3 Then n = n + 1
       Next n
     Next j
     k = k + j - 1
   Next i
   
   strgAddressen = Mid(strgAddressen, 3)
   .Range("A2").Resize(lngEinheiten, UBound(varA, 2)) = varZiel
   .Range(strgAddressen).MergeCells = True
 End With
End Sub

Im Code ist der eingelesene Bereich kenntlich gemacht. Dort gegebenenfalls anpassen.

[Bookshelf3011]

Hallo atilla,

vielen Dank für den Code - das weitere übernehmen klappt wunderbar. Muss ich noch irgendetwas beachten, damit er die leeren Zellen mit übernimmt und diese nicht auffüllt?
Meine VBA-Kenntnisse sind leider noch nicht soweit ausgeprägt, dass ich den Code dementsprechend interpretieren kann.

Vielen Dank und einen schönen Abend.

Mit freundlichem Gruß

Bookshelf3011

[atilla]

Muss ich noch irgendetwas beachten, damit er die leeren Zellen mit übernimmt und diese nicht auffüllt?

Hallo,

tut er das jetzt nicht?

Mit leeren Zellen ist doch gemeint, dass bei Wohneinheiten nichts steht.
Dann sollte mein zuletzt eingestellter Code das doch berücksichtigen.

[Bookshelf3011]

Hallo atilla,

momentan ist es so, dass er die leeren Zeilen in der "Tabelle3" auffüllt, wenn in der Spalte Wohneinheiten kein Wert vorhanden ist.
Liegt es vielleicht daran, dass ich die Variable "n" definiert habe? VBA gibt mir diese nämlich als Fehlermeldung aus, wenn ich den Code ausführen will.
Ich habe "n" als "Long" definiert.

Könnte das der Grund sein?

Mit freundlichem Gruß

Bookshelf3011

[atilla]

Hallo,

mit n hast Du richtig gemacht.

Aber ich bin jetzt ein wenig durcheinander.
Kannst Du bitte am Beispiel erklären, was passiert und was nicht passiert aber passieren soll.

[atilla]

Hallo,

sehe gerade, dass ich den weiter korrigierten Code gar nicht eingestellt habe.
Sorry, ich dachte, dass ich ihn eingestellt hätte.

Hier ist er:

Code:

Sub ordne_um_mit_verbundenen_Zellen2()
 Dim i As Long, j As Long, k As Long, n as Long
 Dim lngZ As Long
 Dim lngAnzahl As Long, lngEinheiten As Long
 Dim strgAddressen As String
 Dim varA, varZiel
 
 With Sheets("Tabelle1")
   lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row
   varA = .Range("A6:K" & lngZ)                        'Bereich, der eingelesen werden soll Hier A6:K bis letzte belegte Zeile in A
   lngEinheiten = Application.Sum(.Range("D6:D" & lngZ))
   If lngZ - 5 > Application.Count(.Range("D6:D" & lngZ)) Then
     lngEinheiten = lngEinheiten + lngZ - 5 - Application.Count(.Range("D6:D" & lngZ))
   End If
 End With
 
 With Sheets("Tabelle3")
   .Columns("D").MergeCells = False
   lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
   .Range("A2").Resize(lngZ - 1, UBound(varA, 2)).ClearContents
   varZiel = .Range("A2").Resize(lngEinheiten, UBound(varA, 2))
   
   For i = LBound(varA) To UBound(varA)
     If varA(i, 4) > 1 Then strgAddressen = strgAddressen & ", " & .Range(.Cells(k + 2, 4), .Cells(k + varA(i, 4) + 1, 4)).Address
     varZiel(k + 1, 4) = varA(i, 4)
     If varA(i, 4) = "" Then varA(i, 4) = 1
     For j = 1 To varA(i, 4)
       For n = 1 To UBound(varA, 2)
         varZiel(k + j, n) = varA(i, n)
         If n = 3 Then n = n + 1
       Next n
     Next j
     k = k + j - 1
   Next i
   
   strgAddressen = Mid(strgAddressen, 3)
   .Range("A2").Resize(lngEinheiten, UBound(varA, 2)) = varZiel
   .Range(strgAddressen).MergeCells = True
 End With
End Sub

[Bookshelf3011]

Guten Abend atilla,

ich hoffe es stört dich nicht, dass ich Screenshots zur besseren Erklärung mit beigefügt habe...

Momentan erhalte ich - sofern die Zelle Wohneinheiten leer ist - den Laufzeitfehler '9'.

Im vorherigen Code gab er mir das Ergebnis aus dem zweiten Screenshot ("Screenshot B") wieder.

   

   

   

Vielen Dank für deine Mühen und einen schönen Sonntagabend.

Mit freundlichem Gruß

Bookshelf3011

[atilla]

Hallo,

ok, ich ging davon aus, dass in WE nicht steht, aber es sind ganze leere Zeilen dazwischen.
Warum???
Lösch sie, das ist ganz einfach. Kopier die Tabelle im Ganzen und lösch die leeren Zeilen und führ den Code dann aus.
Das kann ich, bei bedarf auch einarbeiten.

Ich kann aber auch im bestehenden Code die leeren Zeilen berücksichtigen. Dazu müsste ich noch wissen, ob in WE immer eine Zahl steht.

[Bookshelf3011]

Hallo atilla,

sry, da habe ich mich wohl missverständlich ausgedrückt. Aber um deine Frage zu beantworten:

Ja, in WE steht immer eine Zahl.

Mit freundlichem Gruß

Bookshelf3011

[atilla]

Hallo,

der zueltzt eingestellte Code sollte das machen, was Du möchtest.

Bei mir sieht die Quelle so aus:

Arbeitsblatt mit dem Namen 'Tabelle1'
	A	B	C	D	E	F	G	H	I	J	K
5	Straße	Hausnummer	Zusatz	Wohneinheiten
6	Musterstraße	3		1	e1	f1	g1	h1	i1	j1	k1
7	Musterstraße	17	a	3	e2	f2	g2	h2	i2	j2	k2
8
9	Musterstraße	9		1	e3	f3	g3	h3	i3	j3	k3
10	Musterstraße	8	a	2	e4	f4	g4	h4	i4	j4	k4
11
12	Musterstraße	8		2	e5	f5	g5	h5	i5	j5	k5
13	Musterstraße	7		1	e6	f6	g6	h6	i6	j6	k6

Diese Tabelle wurde mit Tab2Html (v2.4.1) erstellt. ©Gerd alias Bamberg

und nach Codeausführung in Tabelle3 so:

Arbeitsblatt mit dem Namen 'Tabelle3'
	A	B	C	D	E	F	G	H	I	J	K
1	Straße	Hausnummer	zusatz	wohneinheiten	Bemerkunge
2	Musterstraße	3		1	e1	f1	g1	h1	i1	j1	k1
3	Musterstraße	17	a	3	e2	f2	g2	h2	i2	j2	k2
4	Musterstraße	17	a		e2	f2	g2	h2	i2	j2	k2
5	Musterstraße	17	a		e2	f2	g2	h2	i2	j2	k2
6
7	Musterstraße	9		1	e3	f3	g3	h3	i3	j3	k3
8	Musterstraße	8	a	2	e4	f4	g4	h4	i4	j4	k4
9	Musterstraße	8	a		e4	f4	g4	h4	i4	j4	k4
10
11	Musterstraße	8		2	e5	f5	g5	h5	i5	j5	k5
12	Musterstraße	8			e5	f5	g5	h5	i5	j5	k5
13	Musterstraße	7		1	e6	f6	g6	h6	i6	j6	k6

Diese Tabelle wurde mit Tab2Html (v2.4.1) erstellt. ©Gerd alias Bamberg