Kopieren nur wenn noch nicht vorhanden
23.03.2016 07:14:55
Christian
Da ich von VBA noch sehr wenig Ahnung habe, aber ein bestehendes Coding optimieren möchte, muss ich Euch leider wieder um Hilfe bitten.
Wie muss das Coding aussehen, wenn ich die Bemerkungen zu Fragen nur kopieren möchte, wenn diese nicht vorhanden sind? Und wenn kopiert wird, dann soll ein Zeilenumbruch eingestellt werden - derzeit wird nicht umgebrochen, wenn der Text länger ist...
Anbei das Coding sowie File:
https://www.herber.de/bbs/user/104546.xlsm
Private Sub MachMal()
Dim WS1 As Worksheet, WS2 As Worksheet
Dim iZeile As Long, tempZeile As Long
Dim strMark As String
Set WS1 = Worksheets("Fragen")
Set WS2 = Worksheets("Zusammenfassung")
Application.ScreenUpdating = False
For iZeile = WS1.Cells(WS1.Rows.Count, 3).End(xlUp).Row To 5 Step -1
If IsNumeric(WS1.Cells(iZeile, 3)) And WS1.Cells(iZeile, 3) "" Then
Select Case WS1.Cells(iZeile, 3)
Case 10: strMark = "Positive Bemerkungen (10 Punkte):"
Case 6 To 8: strMark = "Hinweise / Verbesserungsvorschläge (6-8 Punkte):"
Case 4: strMark = "Nebenabweichungen (4 Punkte):"
Case 0 To 2: strMark = "Hauptabweichungen (0 - 2 Punkte):"
Case Else: strMark = ""
End Select
If strMark "" Then
tempZeile = Application.Match(strMark, WS2.Columns(2), 0) + 1
WS2.Rows(tempZeile).Insert Shift:=xlDown
WS2.Cells(tempZeile, 1) = WS1.Cells(iZeile, 1)
WS2.Cells(tempZeile, 2) = WS1.Cells(iZeile, 4)
Call ZeileFormatieren(tempZeile, WS2)
End If
End If
Next iZeile
End Sub
Private Sub ZeileFormatieren(Zeile As Long, WS As Worksheet)
With WS.Range(WS.Cells(Zeile, 1), WS.Cells(Zeile, 2))
.Interior.Pattern = xlNone
.Font.Bold = False
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With
End Sub
Besten Dank im Voraus für Eure Unterstützung!!!
Lg,
Chrisi