Makro Anpassung: leere Zellen nicht ignorieren

Hallo liebe Community,
ich hab vor einiger Zeit schon einmal in diesem Forum gepostet und mir wurde auch super geholfen bei meinem Problem. Ich war sehr erstaunt wie nett und hilfsbereit die leute waren und dachte mir, ich Versuch es nocheinmal mein Problem zu schildern.
Ich habe ein bereits bestehendes VBA.. welches auch einwandfrei funktioniert ( dachte ich) nun hab ich aber beim Plausibilitätscheck festgestellt, dass mein einen Fehler hat.
Im Prinziep soll mein Makro so funktionieren. Ausgangspunkt ist eine Tabelle bei der in manchen Zellen mehrere Mitarbeiter stehen durch komma getrennt. Zu jeden Mitarbeiter gibt es Vorgesetzte ( auch durch komma getrennt). Das Makro macht nichts anderes als jeden Mitarbeiter eine extra Zeile anlegen für jeden Vorgesetzten.
Bis dahin klappt es wie ich es will!!!
wenn jetzt aber in der Zelle Vorgesetzter ein blank ist übernimmt er die komplette Zeile nicht... anstatt sie zu kopieren und das blank bestehen zu lassen.
anbei habe ich eine testdatei angehängt, sodass ihr das auch nachvollziehen könnt
https://www.herber.de/bbs/user/79866.xls
ich hoffe es fühlt sich jemand angesprochen und kann mir bei diesem Problem helfen
tausen dank im Vorraus
Mfg
Robert

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Robert,
wenn eine der Zellen leer ist, dann muss hilfsweise ein Leerzeichen (Blank) gesplittet werden, um ein Array zu erzeugen. Beim Eintragen werden überzählige Leerzeichen mit Trim wieder entfert.
Gruß
Franz

Sub test()
'Namen der Mitarbeiter und Vorgestzten Splitten und Zeilen ggf. mehrfach kopieren
'Daten werden in neuem Tabellenblatt ausgegeben
Dim wksOrig As Worksheet, wksNeu As Worksheet
Dim lngOrig As Long, lngNeu As Long
Dim intBoss As Integer, arrBoss
Dim intMA As Integer, arrMA
Dim intUBC As Integer, arrUBC
Const SpalteBoss As Long = 10 'Spalte J
Const SpalteMA As Long = 9 'Spalte I
Const SpalteUBC As Long = 11 'Spalte K
Set wksOrig = ActiveSheet
Set wksNeu = ActiveWorkbook.Worksheets.Add(after:=wksOrig)
wksNeu.Name = wksOrig.Name & " Neu"
lngNeu = 1
Application.ScreenUpdating = False
With wksOrig
.Rows(1).Copy wksNeu.Cells(lngNeu, 1)
wksNeu.Cells(1, 1) = "Ergebnis"
For lngOrig = 2 To .Cells(.Rows.Count, SpalteBoss).End(xlUp).Row
Application.StatusBar = "Bearbeite Zeile: " & Format(lngOrig, "0000")
If IsEmpty(.Cells(lngOrig, SpalteMA)) Then
arrMA = Split(" ", ",")
Else
arrMA = Split(.Cells(lngOrig, SpalteMA), ",")
End If
If IsEmpty(.Cells(lngOrig, SpalteBoss)) Then
arrBoss = Split(" ", ",")
Else
arrBoss = Split(.Cells(lngOrig, SpalteBoss), ",")
End If
If IsEmpty(.Cells(lngOrig, SpalteUBC)) Then
arrUBC = Split(" ", ",")
Else
arrUBC = Split(.Cells(lngOrig, SpalteUBC), ",")
End If
For intMA = LBound(arrMA) To UBound(arrMA)
For intBoss = LBound(arrBoss) To UBound(arrBoss)
For intUBC = LBound(arrUBC) To UBound(arrUBC)
lngNeu = lngNeu + 1
.Rows(lngOrig).Copy wksNeu.Cells(lngNeu, 1)
wksNeu.Cells(lngNeu, SpalteMA).Value = Trim(arrMA(intMA))
wksNeu.Cells(lngNeu, SpalteBoss).Value = Trim(arrBoss(intBoss))
wksNeu.Cells(lngNeu, SpalteUBC).Value = Trim(arrUBC(intUBC))
Next
Next
Next
Erase arrBoss
Erase arrMA
Erase arrUBC
Next
End With
wksNeu.UsedRange.EntireColumn.AutoFit
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub

Beliebteste Forumthreads (12 Monate)

Makro Anpassung: leere Zellen nicht ignorieren

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

341 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Makro Anpassung: leere Zellen nicht ignorieren

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

341 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread