AW: Auflistung gleicher Zellinhalte die Zweite
27.08.2009 18:16:30
fcs
Hallo Lothar,
also ich würde es so machen:
1. Löschen aller Zeilen mit bereits nachgetragenen Positionsnummern
2. Löschen der Inhalte mit Einträgen für Aufmass Blattnummer
Damit ist das Blatt LV wieder "jungfräulich".
3. Alle Daten aus Blatt Gesamt übertragen und dabei für mehrfach vorkommende Pos-Nummern jeweils die Zusatzzeile(n) einfügen und ausfüllen.
Das folgende Makro setzt das um.
In deiner Beispieldatei sind die Zeilen in den Spalten S, T und U nicht mehr korrekt mit den übrigen Zeilen ausgerichtet. Ist wahrscheinlich beim Basteln der Beispieldatei passiert.
Gruß
Franz
Sub LV_Aufmass_aktualisieren()
Dim wksLV As Worksheet, wksGesamt As Worksheet
Dim ZeileLV As Long, ZeileGesamt As Long
Dim ZelleLV As Range, strPosition As String
Dim dblAufmass As Double, varBlatt As Variant
Set wksLV = Worksheets("LV")
Set wksGesamt = Worksheets("Gesamt")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Alle bereits eingetragenen Daten aus LV entfernen
With wksLV
'Zusätzlich eingefügte Zeilen löschen
For ZeileLV = .Cells(.Rows.Count, 1).End(xlUp).Row To 4 Step -1
If .Cells(ZeileLV, 1).Text = .Cells(ZeileLV - 1, 1).Text Then
.Rows(ZeileLV).Delete
End If
Next
'Einträge für Aufmass und Blatt löschen
.Range(.Cells(3, 8), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 8)).ClearContents
.Range(.Cells(3, 13), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 13)).ClearContents
End With
'Einträge aus Blatt Gesamt in LV eintragen
With wksGesamt
For ZeileGesamt = 3 To .Cells(.Rows.Count, 2).End(xlUp).Row
'Zu übertragende Werte merken
strPosition = .Cells(ZeileGesamt, 2).Text 'Position - Spalte B
dblAufmass = .Cells(ZeileGesamt, 11).Value 'Aufmasswert - Spalte K
varBlatt = .Cells(ZeileGesamt, 18).Value 'Blatt - Spalte R
With wksLV
'Position in Spalte A (1) de LV suchen
Set ZelleLV = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Find _
(what:=strPosition, LookIn:=xlValues, lookat:=xlWhole)
If ZelleLV Is Nothing Then
MsgBox "Die Position """ & strPosition & """ in Zeile " & ZeileGesamt _
& " des Blatts """ & .Name & """ ist im LV nicht vorhanden!"
Else
If IsEmpty(.Cells(ZelleLV.Row, 8)) Then
'Noch kein Aufmass für Position eingetragen
.Cells(ZelleLV.Row, 8).Value = dblAufmass
.Cells(ZelleLV.Row, 13).Value = varBlatt
Else
'Mindestens ein Aufmass ist bereits eingetragen
ZeileLV = ZelleLV.Row
'Nächste Zeile mit anderer Positionsnummer suchen
Do Until .Cells(ZeileLV, 1).Text strPosition
ZeileLV = ZeileLV + 1
Loop
'Leerzeile einfügen
.Rows(ZeileLV).Insert shift:=xlShiftDown
'Positionsnummer in Spalte A eintragen und Schrift wie Zellhintergrund formatieren
With .Cells(ZeileLV, 1)
.Value = strPosition
.Font.ColorIndex = .Interior.ColorIndex
End With
'Aufmass und Blatt eintragen
.Cells(ZeileLV, 8).Value = dblAufmass
.Cells(ZeileLV, 13).Value = varBlatt
End If
End If
End With
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub