Hallo ! Da bin ich wieder. Keine Angst - mein Ergeiz war da geweckt. Hat mich zwar ein wenig Zeit (länger als erwartet) und Nerven gekostet (es lief mal und wollte dann plötzlich dann doch nicht mehr) aber jetzt läuft es. Da ich mit einer alten Excelversion werkel, musste ich die xlsm erst noch umwandeln. Danach konnte ich sie zwar nicht mehr nutzen, aber zumindest die Tabellenblätter übernehmen. Mit deinem Sheetaufbau habe ich es nun hingebastelt. Einfach wieder einfügen und dann sollte es klappen. Falls wiedererwarten doch nicht, einfach nochmal melden. Gruß
Anbei noch der Link zu meiner Datei (da sind die ausgeblendeten Sheets und Diese Arbeitsmappe2 nicht mit dabei.
http://www.file-upload.net/download-11134339/zeilenkopierenrumeneu.xls.html
und hier der code zum enfügen.
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim suche
Dim ende As Long
Dim ende2 As Long
Dim endesh As Long
Dim anzahl As Long
Dim i As Long
Dim zeile As Integer
Dim zeilesh As Integer
Dim gefunden As Boolean
Dim adresse As String
Dim blatt()
Dim temp
Dim anzsuch
blatt = Array("", "Kursaal", "Galerie", "Konferenzraum")
If Sh.Index < 4 Then 'nur wenn Blatt 1bis 3
If Target.Row > 8 Then 'Eintrag ab 9
suche = Worksheets(Sh.Index).Cells(Target.Row, 1) 'datum wird gesucht
anzsuch = 0
anzsuch = Application.WorksheetFunction.CountIf(Worksheets(4).Columns(1), suche)
If suche = "" Then Exit Sub
If anzsuch = 0 Then
ende = Worksheets(4).Cells(Rows.Count, 1).End(xlUp).Row
Worksheets(4).Cells(ende + 1, 1) = suche
Worksheets(4).Cells.Rows(ende + 1).Borders(xlInsideVertical).LineStyle = xlNone
Worksheets(4).Cells.Rows(ende + 1).Borders(xlEdgeLeft).LineStyle = xlNone
Worksheets(4).Cells.Rows(ende + 1).Borders(xlEdgeRight).LineStyle = xlNone
Worksheets(Sh.Index).Rows(Target.Row).Copy Destination:=Worksheets(4).Rows(ende + 1 + Sh.Index)
Worksheets(4).Cells(ende + 2, 1) = suche
Worksheets(4).Cells(ende + 2, 4) = blatt(1)
Worksheets(4).Cells(ende + 3, 1) = suche
Worksheets(4).Cells(ende + 3, 4) = blatt(2)
Worksheets(4).Cells(ende + 4, 1) = suche
Worksheets(4).Cells(ende + 4, 4) = blatt(3)
Else
'es gibt eine wert suchen und eintragen
suche = CLng(CDate(suche))
zeile = Application.WorksheetFunction.Match(CLng(suche), Worksheets(4).Columns(1), 0)
zeile = zeile + 1
gefunden = False
While gefunden = False
If Worksheets(4).Cells(zeile, 4) = blatt(Trim(Sh.Index)) Then
gefunden = True
anzahl = Application.WorksheetFunction.CountIf(Worksheets(Sh.Index).Range(Worksheets(Sh.Index).Cells(9, 1), Cells(Rows.Count, 1)), suche)
temp = Application.WorksheetFunction.Match(CLng(suche), Worksheets(Sh.Index).Columns(1), 0)
zeilesh = temp
For i = 1 To anzahl
If Worksheets(4).Cells(zeile, 4) = blatt(Trim(Sh.Index)) Then
Worksheets(Sh.Index).Rows(zeilesh).Copy Destination:=Worksheets(4).Rows(zeile)
Worksheets(4).Cells(zeile, 4) = blatt(Trim(Sh.Index))
Worksheets(4).Cells(zeile, 1) = CDate(suche)
Else
'neuer wert, zeile einfügen
Worksheets(4).Rows(zeile).EntireRow.Insert Shift:=xlDown
Worksheets(Sh.Index).Rows(zeilesh).Copy Destination:=Worksheets(4).Rows(zeile)
Worksheets(4).Cells(zeile, 4) = blatt(Trim(Sh.Index))
Worksheets(4).Cells(zeile, 1) = CDate(suche)
End If
If i < anzahl Then
ende2 = Worksheets(Sh.Index).Cells(Rows.Count, 1).End(xlUp).Row
temp = Application.WorksheetFunction.Match(CLng(suche), Worksheets(Sh.Index).Columns(1).Rows(zeilesh & ":" & ende2), 0)
zeilesh = temp + zeilesh
End If
zeile = zeile + 1
Next i
Else
zeile = zeile + 1
End If
If zeile > Worksheets(4).Cells(Rows.Count, 1).End(xlUp).Row + 2 Then gefunden = True
Wend
End If
End If
End If
Worksheets(4).Cells.Interior.ColorIndex = xlNone
End Sub
|