Zellen werden wegen Makro überschrieben
05.08.2019 14:44:32
Denis
kann mir jemand auf Basis des untenstehenden Makros beschreiben, was ich verändern muss, um in Zeile 6 von Spalte A - I Überschriften festzulegen ohne, dass diese immer wieder gelöscht werden - komme nicht drauf.
Außerdem möchte ich das in den ersten vier Zeilen Inhalte aus einem anderen Tabellenblatt kopiert werden (z. T. mit verbundenen Zellen). Auch diese werden - bis auf die Formatierung - überschrieben.
Danke schonmal für jeden Hinweis!
Grüße
Denis
Sub Auswertung()
Dim ersterFund As String
Dim letztezeileS As Long
Dim suchErgebnis As Object
Dim wb As Workbook
Dim wsE As Worksheet ' Blätter mit Eingabedaten (nacheinander)
Dim wsS As Worksheet ' Blatt "Summary"
Dim zeileE As Long
Dim zeileS As Long
Set wb = ThisWorkbook
Set wsS = wb.Worksheets("Summary")
letztezeileS = wsS.Cells(wsS.Rows.Count, "A").End(xlUp).Row
If letztezeileS > 1 Then
wsS.Rows(2).Resize(letztezeileS - 1).ClearContents
End If
zeileS = 7
For Each wsE In wb.Worksheets
If wsE.Range("A2") = "ID No." And _
wsE.Range("B2") = "List of Questions" Then
Set suchErgebnis = wsE.Columns("A").Find(what:="ID No.", _
lookat:=xlWhole)
If Not suchErgebnis Is Nothing Then
ersterFund = suchErgebnis.Address
Do
zeileE = suchErgebnis.Row + 1
Do Until IsEmpty(wsE.Cells(zeileE, "A"))
If wsE.Cells(zeileE, "P") = "high" Or _
wsE.Cells(zeileE, "P") = "medium" Then
wsS.Cells(zeileS, "A") = wsE.Name
wsS.Cells(zeileS, "B") = wsE.Cells(zeileE, "A") ' Id No.
wsS.Cells(zeileS, "C") = wsE.Cells(zeileE, "B") ' Question
wsS.Cells(zeileS, "D") = wsE.Cells(zeileE, "P") ' Benchmark
wsS.Cells(zeileS, "E") = wsE.Cells(zeileE, "U") ' Remark
zeileS = zeileS + 1
End If
zeileE = zeileE + 1
Loop
Set suchErgebnis = wsE.Columns("A").FindNext(After:=suchErgebnis)
Loop While Not suchErgebnis Is Nothing And suchErgebnis.Address ersterFund
End If
End If
Next wsE
End Sub