Ähnliche Einträge suchen und Löschen

Guten Tag VBA-Experten,
ich habe ein Problem und hoffe mir kann hier jemand helfen.
Zum Verständnis hole ich mit meiner Beschreibung des Problems etwas weiter aus. Ich muss beruflich zwei Excel Worksheets bearbeiten. Wobei die eine, nennen wir sie "Blatt 1", zu Beginn eher unwichtig ist. Auf "Blatt 2" befinden sich Artikelnummern in Zeile 1 aufgelistet (Spaltenanzahl kann variieren), wobei diese in Fertigartikel mit der Form 123456 Fert, Werkzeugen zu den Fertigartikel in der Form 123456 WKZ und den konsolidierten S-Artikeln 123456S aufgeführt sind. Wenn ein Artikel im S-Format vorhanden ist, soll die Artikelnummer 123456S ausgelesen und in "Blatt 1" Zeile 1 kopiert werden (die dortigen Rechenoperationen funktionieren). Wenn es nun zu dem gefundenen S-Artikel WKZ und Fert gibt, sollen diese Spalten gelöscht werden.
Jemand eine Ahnung mit welchem Befehlen das geht? Bin leider neu im VBA-Coding und komme gerade nicht weiter.
Danke schonmal

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Unit() Dim Blatt1 As Worksheet, Blatt2 As Worksheet, C As Range, i As Long Set Blatt2 = Worksheets("Tabelle1") 'ANPASSEN Set Blatt1 = Worksheets("Tabelle2") 'ANPASSEN For Each C In Blatt2.Range(Blatt2.Cells(1, 1), Blatt2.Cells(1, Columns.Count).End(xlToLeft)) If C Like "######S" Then i = i + 1 Blatt1.Cells(1, i) = C End If Next For i = Blatt2.Cells(1, Columns.Count).End(xlToLeft).Column To 1 Step -1 If InStr(Blatt2.Cells(1, i), "WKZ") > 0 Or InStr(Blatt2.Cells(1, i), "Fert") > 0 Then If WorksheetFunction.CountIf(Blatt2.Rows(1), Left(Blatt2.Cells(1, i), 6) & "S") > 0 Then Blatt2.Columns(i).Delete End If End If Next Set Blatt1 = Nothing Set Blatt2 = Nothing End Sub

Sub test() Dim s_artikel() As Variant Dim blatt1 As Worksheet Dim blatt2 As Worksheet Set blatt1 = Worksheets("Tabelle1") Set blatt2 = Worksheets("Tabelle2") s_artikel = Array() blatt2.Activate Dim last_row As Integer Dim last_column As Integer last_row = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row last_column = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column ReDim s_artikel(1 To last_column + 1) Dim p As Integer Dim i As Integer i = 1 For p = 1 To last_column If blatt2.Cells(1, p) Like "######S*" Then 'MsgBox ("s gefunden")--> suchen funktioniert nun folgt kopieren s_artikel(i) = blatt2.Cells(1, p) i = i + 1 Else End If Next p Dim u As Integer Dim b As String For u = 1 To UBound(s_artikel) If Left(s_artikel(u), 6) = Left(blatt2.Range("1:1")) Then 'blatt2.Columns(u).Delete Else End If Next u End Sub

Guten morgen Gerd,
hast wohl recht ich habe versucht es möglichst treffend darzustellen. Im Endeffekt hat dein Code doch funktioniert, ich hatte nur irgendwo einen Fehler eingebaut. In dem Excel Sheet, was ich mit hochlade, wären dann die 200000 FERT und 200000_WKZ schon entfernt. Nun wollte ich noch andere Posten die in dem Sheet sind, hier als Bahn usw. gelistet, löschen. Meine Idee war auch wieder über InStr, aber das haut nicht so hin.
Zuletzt bin ich auch noch nicht komplett dahinter gestiegen, wie ich die FERT und WKZ Artikel ohne gemeinsamen S-Artikel mit einander verrechne. Heißt WKZ konsolidiert mit FERT oder umgekehrt, schenkt sich nichts und dann soll quasi für diesen konsolidierten Wert eine S-Spalte angelegt werden und die anderen beiden gelöscht werden. Dies ginge ja wieder mit deinem vorigen Code. Problem hier ist die WZK und FERT stehen nicht unbedingt nebeneinander, so wie in meinem Beispiel. Wirklich vielen Dank, dass dir die Zeit nimmst.


Sub Neue_GuV_implementieren()
Dim blatt1 As Worksheet
Dim blatt2 As Worksheet
Dim r As Range
Dim i As Long
Set blatt1 = Worksheets("Tabelle1")
Set blatt2 = Worksheets("Tabelle2")
For Each r In blatt2.Range(blatt2.Cells(1, 1), _
blatt2.Cells(1, Columns.Count).End(xlToLeft))
If r Like "######S*" Then
i = i + 1
End If
Next
For i = blatt2.Cells(1, Columns.Count).End(xlToLeft).Column To 1 Step -1
If InStr(blatt2.Cells(1, i), "WKZ") > 0 Or InStr(blatt2.Cells(1, i), " FERT") > 0 Then
If WorksheetFunction.CountIf(blatt2.Rows(1), Left(blatt2.Cells(1, i + 1), 6) & "S*") > 0 Then
blatt2.Columns(i).Delete
End If
End If
Next
'For i = blatt2.Cells(1, Columns.Count).End(xlToLeft).Column To 2 Step -1
'If InStr(blatt2.Cells(1, i), "*WKZ*") > 0 Or _
InStr(blatt2.Cells(1, i), "*FERT*") > 0 Or _
InStr(blatt2.Cells(1, i), "######S*") > 0 Then
'Else
'blatt2.Columns(i).Delete
'End If
'Next
Set blatt1 = Nothing
Set blatt2 = Nothing
End If
End Sub

Tabelle: https://www.herber.de/bbs/user/148198.xlsx

Beliebteste Forumthreads (12 Monate)

Ähnliche Einträge suchen und Löschen

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Ähnliche Einträge suchen und Löschen

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread