AW: Kopieren ohne Zellfarbe
29.12.2020 14:42:06
Ulrich
Hallo Nepumuk,
ich habe noch eine kurze Frage.
Du hattest mir den folgenden Code angepasst. (Übertrag in To Do Liste)
Der funktioniert einwandfrei, nur wird beim Einlesen der Daten der Zeilenumbruch in der Zelle rausgenommen.
Lässt sich das ändern?
Gruß Ulli
Option Explicit
Public Sub To_Do_Uebertragen()
Dim i As Long, j As Long, lngLastRow As Long
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
With Worksheets("Übertrag to do")
.Unprotect
j = 6
Call .Range(.Cells(6, 1), .Cells(.Rows.Count, 6)).Clear
With Worksheets("Gefährdungsbeurteilung")
lngLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
For i = 7 To lngLastRow
If Not Worksheets("Gefährdungsbeurteilung").Rows(i).Hidden Then
If Not Worksheets("Gefährdungsbeurteilung").Cells(i, 10).Value = "" Then
.Cells(j, 2).Value = Worksheets("Gefährdungsbeurteilung").Cells(i, 1).Value
.Cells(j, 3).Value = Worksheets("Gefährdungsbeurteilung").Cells(i, 7).Value
.Cells(j, 4).Value = Worksheets("Gefährdungsbeurteilung").Cells(i, 9).Value
.Cells(j, 5).Value = Worksheets("Gefährdungsbeurteilung").Cells(i, 10). _
Value
.Cells(j, 6).FormulaLocal = "=WENN(Gefährdungsbeurteilung!K" & i & _
"="""";"""";WENN(Gefährdungsbeurteilung!L" & i & "="""";"""";""P""))"
j = j + 1
End If
End If
Next i
lngLastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
If lngLastRow > 6 Then
With .Range(.Cells(6, 1), .Cells(lngLastRow, 6))
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
With .Font
.Name = "Arial"
.Size = 10
.Bold = False
.ColorIndex = 0
End With
End With
.Range(.Cells(6, 3), .Cells(lngLastRow, 3)).HorizontalAlignment = xlLeft
.Range(.Cells(6, 2), .Cells(lngLastRow, 2)).Font.Bold = True
.Range(.Cells(6, 2), .Cells(lngLastRow, 2)).NumberFormat = "0"".""#0"".""0"
With .Range(.Cells(6, 1), .Cells(lngLastRow, 6))
Call .BorderAround(LineStyle:=xlContinuous)
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
End With
With .Range(.Cells(6, 6), .Cells(lngLastRow, 6)).Font
.Name = "Wingdings 2"
.Size = 16
.Bold = True
.Color = -16711936
End With
'Fortlaufende Nummer
.Cells(6, 1).Value = 1
Call .Range(.Cells(6, 1), .Cells(lngLastRow, 1)).DataSeries( _
Rowcol:=xlColumns, Type:=xlDataSeriesLinear, Step:=1)
End If
.Protect
End With
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
