Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1568to1572
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
Inhaltsverzeichnis

VBA: Leere Zellen in Tabelle füllen-mit Bedingung

VBA: Leere Zellen in Tabelle füllen-mit Bedingung
27.07.2017 09:56:16
Fabian
Liebes Forum,
ich stehe vor folgender Herausforderung:Ich möchte in einer Tabelle leerze Zellen unter Abhängigkeit zur Splate A mit Text füllen.
Ich habe eine Liste mit ID in Spalte A, Firmennamen in Spalte B, Firmenanschrift in Spalte C und die Tochterunternehmen in Spalte D sowie weitere Attribute in den darauffolgenden Spalten bis EY.
Jetzt ist es so, dass bspw. in Zeile 2 der Firmenname steht und in Spalte D 2,3,4,…..100 jeweils in einer separaten Zelle untereinander die Tochtergesellschaften. Jetzt möchte ich ganz gerne die leeren Zellen mit den darüberliegenden Informationen füllen:
ID Firma A Adresse A Tochter 1 Manager X …
1 Tochter 2 Manager XX
Tochter 3
Tochter 4
2 Firma B Adresse B Tochter 1
Den oberen Wert nach unten kopieren klappt mit folgendem VBA schon sehr gut. Nur habe ich das _
Problem, dass IMMER der obrige Wert Kopiert wird. Fehlt bspw. eine Information bei einem _
Unternehmen, so wird eine falsche Information „runter kopiert“:

Sub FillColBlanks()
Dim wks As Worksheet
Dim rng As Range
Dim LastRow As Long
Dim col As Long
Application.ScreenUpdating = False
Set wks = ActiveSheet
With wks
For col = 1 To Cells(1, 155).Column
Set rng = .UsedRange  'try to reset the lastcell
LastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
Set rng = Nothing
On Error Resume Next
Set rng = .Range(.Cells(2, col), .Cells(LastRow, col)) _
.Cells.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "No blanks found"
Application.ScreenUpdating = True
Exit Sub
Else
rng.FormulaR1C1 = "=R[-1]C"
End If
'replace formulas with values
With .Cells(1, col).EntireColumn
.Value = .Value
End With
Next col
End With
Application.ScreenUpdating = True
End Sub

1 Firma A Adresse A Tochter A1 Manager A …
1 Firma A Adresse A Tochter A2 Manager A …
1 Firma A Adresse A Tochter A3 Manager A …
1 Firma A Adresse A Tochter A4 Manager A …
2 Firma B Adresse B Tochter B1 Manager A …
3 Firma C Adresse B Tochter B1 Manager A …
4 Firma D Adresse B Tochter B1 Manager A …
5 Firma E Adresse E Tochter E1 Manager E …
Nun habe ich zwischen jedem neuen Eintrag eine Leerzeile eingefügt.
Ein neuer Eintrag ist dann, wenn ich einen „Change in Value“ in Spalte A habe.
Die Herausforderung besteht allerdings weiterhin. Wie teile ich Excel mit nur dann den oberen Wert runter zu kopieren, wenn dieser auch zur gleichen ID/Company gehört?
Ich freue mich auf eure Lösungsvorschläge!

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA: Leere Zellen in Tabelle füllen-mit Bedingung
28.07.2017 07:23:04
fcs
Hallo Fabian,
in deinem Fall muss man das Problem zeileweise angehen und in Blöcken je Firma die Formeln einfügen.
Dabei darf in der Zeile mit der ID keine Formel eingefügt werden.
Gruß
Franz

Sub FillColBlanks()
Dim wks As Worksheet
Dim rng As Range
Dim LastRow As Long
Dim col As Long
Dim Zei As Long, Zei1 As Long, Zei2 As Long, StatusCalc As Long
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
On Error GoTo Fehler
Set wks = ActiveSheet
With wks
col = 155                           'letzte Spalte die mit Formeln gefüllt werden soll
LastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row + 1
Zei1 = 2                        '2 = Zeile mit ID der 1. Firma ggf. anpassen
Zei2 = Zei1
For Zei = Zei1 To LastRow
If .Cells(Zei, 1).Text  "" Or Zei = LastRow Then
Zei2 = Zei - 1
If Zei2 > Zei1 Then
Set rng = .Range(.Cells(Zei1 + 1, 1), .Cells(Zei2, col))
If Application.WorksheetFunction.CountBlank(rng) > 0 Then
rng.Cells.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = _
"=if(R[-1]C"""",R[-1]C,"""")"
End If
Resume01:
Zei1 = Zei
Zei2 = Zei1
End If
End If
Next Zei
'replace formulas with values
With .UsedRange
.Calculate
.Value = .Value
End With
End With
Fehler:
With Err
Select Case .Number
Case 0
Case 1004 'SpecialCells(xlCellTypeBlanks) hat im Block keine Leer-Zellen gefunden
Resume Resume01
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, _
vbOKOnly, "Fehlermeldung - Makro: FillolBlanks"
End Select
End With
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
End With
End Sub

Anzeige

348 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige