AW: Zeilen zusammenfassen wenn ein Wert übereinstimmt
17.09.2009 18:00:41
fcs
Hallo Chris,
hier eine Lösung.
Gruß
Franz
Sub Mon_nach_Datei_variante()
Dim wksQuelle As Worksheet
Dim wbZiel As Workbook, wksZiel As Worksheet, rngWKZ As Range
Dim varMon, varAVO, varWKZ, bolErste As Boolean
Dim ZeileQ As Long
varMon = Application.InputBox(Prompt:="Bitte Mon-Nummer eingeben", Type:=1)
If varMon = False Then Exit Sub
'Daten-Quelle setzen
Set wksQuelle = ActiveSheet
'Neue Datei anlegen
Application.Workbooks.Add Template:=xlWBATWorksheet
Set wbZiel = ActiveWorkbook
Set wksZiel = wbZiel.Worksheets(1)
With wksZiel
'Tabellenblatt benamen
.Name = "Mon_" & varMon
'Titelzeilen eintragen
.Cells(1, 1) = "Mon"
.Cells(1, 2) = varMon
.Cells(2, 1) = "AVO"
.Cells(2, 2) = "WKZ"
'Titelzeilen fixieren
Range("A3").Select
ActiveWindow.FreezePanes = True
'Tabelenblatt benamen
.Name = "Mon_" & varMon
End With
With wksQuelle
'Zeilen in Liste abarbeiten
For ZeileQ = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
'Zeilen ohne Eintrag in WKZ überspringen
If Not IsEmpty(.Cells(ZeileQ, 3)) Then
'Mon-Nummer vergleichen
If .Cells(ZeileQ, 1) = varMon Then
varAVO = .Cells(ZeileQ, 2)
varWKZ = .Cells(ZeileQ, 3)
With wksZiel
If bolErste = False Then
.Cells(3, 1) = varAVO
.Cells(3, 2) = varWKZ
bolErste = True
Else
'WKZ in Spalte B suchen
With .Range(.Cells(2, 2), .Cells(2, 2).End(xlDown))
Set rngWKZ = .Find(what:=varWKZ, LookIn:=xlValues, lookat:=xlWhole, _
MatchCase:=True)
If rngWKZ Is Nothing Then
'WKZ in nächste freie Zelle eintragen
With .Range("A1").End(xlDown).Offset(1, 0)
.Value = varWKZ
.Offset(0, -1).Value = varAVO
End With
Else
'AVO in Zeile ergänzen
rngWKZ.Offset(0, -1).Value = rngWKZ.Offset(0, -1).Value & ", " & varAVO
End If
End With
End If
End With
End If
End If
Next
End With
wksZiel.Columns(1).AutoFit
wbZiel.Activate
Application.Dialogs(xlDialogSaveAs).Show Arg1:="Mon_" & varMon
End Sub