Bereits bekannte Zeilen erkennen und ausfüllen

Hallo Zusammen,
ich kopiere in eine fortlaufende Excelliste jeden Tag neue Fehler. Jeder Fehler ist in den Spalten D bis M beschrieben ( Fehler Id, System usw. ). Je nach Fehler trage ich in die Spalten O bis U Dinge zum weiteren Vorgehen ein.
Da sich viele Fehler wiederholen, würde ich gerne ein Makro programmieren, welches für die neuen Fehler checked, ob es diesen Fehler schon gibt und dann entsprechend ausfüllt, was ich bereits bei einem bestehenden Fehler ausgefüllt habe in O bis U.
Dann müsste ich nur noch für wirklich neue Fehler das Vorgehen ausfüllen. Wichtig: von A-C stehen Daten die bei jedem Fehler anders sind. Daher kann durch das Makro nicht einfach die ganze Zeile überschrieben werden.
Eine Beispieldatei dazu gibt's hier: https://www.herber.de/bbs/user/109654.xlsm
Vielen Dank im Voraus. Ich habe keine Ahnung momentan, wie ich da rangehen soll.
Grüße
Marv

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

So Marv =D
Du Kopierst die Werte( nur die Werte )
Fehler0,FehlerOrt0,Fehler1,FehlerOrt1,Fehler2,FehlerOrt2,Fehler3,FehlerOrt3,IFD
Genau in dieser ReihenFolge
Und dann einfach das Makro starten
Gruß Basti

' Verweis auf Microsoft Forms2 Objekt
Sub Suche_Fehler_ID()
On Error GoTo ende
Dim A, B, r, rr, cc
Dim Lastcell As Range
A = ClipToArray()
With ActiveSheet
Set Lastcell = .Cells(.Rows.Count, 21).End(xlUp)
B = .Range(.Cells(1, 4), Lastcell).Value
ReDim Preserve A(UBound(A, 1), UBound(B, 2) - 1)
For r = LBound(A, 1) To UBound(A, 1)
For rr = LBound(B, 1) + 1 To UBound(B, 1)
If CDbl(A(r, 0)) = B(rr, 1) Then
For cc = 12 To UBound(B, 2)
A(r, cc - 1) = B(rr, cc)
Next
End If
Next
Next
.Range(.Cells(Lastcell.Row + 1, 4), .Cells(Lastcell.Row + 1, 4).Resize(UBound(A, 1) + 1,  _
UBound(A, 2) + 1)) = A
End With
ende:
End Sub
Function ClipToArray() As Variant
On Error Resume Next
Dim clip As New MSForms.DataObject
Dim ClipToArrayin
Dim lines As String
clip.GetFromClipboard
lines = clip.GetText
lines = Replace(lines, vbCr, "")
ReDim ClipToArrayin(UBound(Split(lines, vbLf)) - 1, UBound(Split(Split(lines, vbLf)(r), vbTab))) _
For r = LBound(Split(lines, vbLf)) To UBound(Split(lines, vbLf)) - 1
For c = LBound(Split(Split(lines, vbLf)(r), vbTab)) To UBound(Split(Split(lines, vbLf)(r),  _
vbTab))
ClipToArrayin(r, c) = Split(Split(lines, vbLf)(r), vbTab)(c)
Next
Next
ClipToArray = ClipToArrayin
End Function

' Verweis auf Microsoft Forms2 Objekt Sub Suche_Fehler_ID() On Error GoTo ende Dim A, B, r, rr, cc Dim Lastcell As Range A = ClipToArray() With ActiveSheet Set Lastcell = .Cells(.Rows.Count, 4).End(xlUp) B = .Range(.Cells(1, 4), .Cells(Lastcell.Row, 21)).Value ReDim Preserve A(UBound(A, 1), UBound(B, 2) - 1) For r = LBound(A, 1) To UBound(A, 1) For rr = LBound(B, 1) + 1 To UBound(B, 1) For c = LBound(A, 2) To 9 If CStr(A(r, c)) CStr(B(rr, c + 1)) Then GoTo Jump End If Next For cc = 12 To UBound(B, 2) A(r, cc - 1) = B(rr, cc) Next GoTo Jump2 Jump: Next Jump2: Next .Range(.Cells(Lastcell.Row + 1, 4), .Cells(Lastcell.Row + 1, 4).Resize(UBound(A, 1) + 1, _ UBound(A, 2) + 1)) = A End With ende: End Sub

Sub Suche_Fehler_ID() On Error GoTo ende Dim A, B, r, rr, cc Dim Lastcell As Range A = ClipToArray() With ActiveSheet Set Lastcell = .Cells(.Rows.Count, 4).End(xlUp) B = .Range(.Cells(1, 1), .Cells(Lastcell.Row, 21)).Value ReDim Preserve A(UBound(A, 1), UBound(B, 2) - 1) For r = LBound(A, 1) To UBound(A, 1) For rr = LBound(B, 1) + 1 To UBound(B, 1) For c = LBound(A, 2) + 3 To 12 If CStr(A(r, c)) CStr(B(rr, c + 1)) Then GoTo Jump End If Next For cc = 15 To UBound(B, 2) A(r, cc - 1) = B(rr, cc) Next GoTo Jump2 Jump: Next Jump2: Next .Cells(Lastcell.Row + 1, 1).Resize(UBound(A, 1) + 1, UBound(A, 2) + 1) = A End With ende: End Sub

Beliebteste Forumthreads (12 Monate)

Bereits bekannte Zeilen erkennen und ausfüllen

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread