Duplikate in Workbook finden und Nachbarzelle kopi

Guten Tag zusammen,
wie so viele hier, habe ich auch ein kleines Problem, bei dem ich nicht weiterkomme.
Ich habe eine Datei in die ich über "Application.GetOpenFilename" eine beliebige Anzahl an CSV-Dateien importiere. Es wird für jede CSV ein eigenes Worksheet erstellt mit dem Namen der Ursprungsdatei. Anschließend wird alles passend formatiert. Soweit funktioniert alles.
Nun zum Problem:
Die Arbeitsblätter sind alle gleich aufgebaut. In Spalte 4 stehen Texte. Die Spalte 5 ist leer. Sie ist für eventuelle Übersetzungen der Spalte 4 gedacht. Von mir gewünscht ist, dass ein Vergleich des Textes in Spalte 4 über alle Tabellenblätter durchgeführt wird. Sobald ein Duplikat gefunden wurde und es eine Übersetzung in Spalte 5 dazu gibt, soll diese Übersetzung auch für alle Duplikate verwendet werden. Ergo in die Nachzelle kopiert werden.
Möchte mir damit etwas Zeit bei der Übersetzung sparen, da ich viele gleiche Texte in Spalte 4 habe.
Vielen Dank schon mal im Voraus für eure Mühe

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

ansonsten kannst du auch mal dieses Makro probieren:
in einer ersten Schleife werden die vorhandenen Übersetzungen gesammelt.
in der zweiten Schleife werden dann die Übersetzungen an die Duplikate, bei denen sie fehlen zurückgeschrieben.
sollte es für einen Text verschiedene Übersetzungen geben, so wird für die fehlenden die letzte gefundene verwendet:

Sub test()
Dim sh As Worksheet
Dim ÜB As Object
Dim arr
Dim z As Long
Set ÜB = CreateObject("Scripting.Dictionary")
'--- vorhandene Übersetzungen einlesen
For Each sh In ActiveWorkbook.Worksheets
arr = sh.UsedRange.Columns(4).Resize(, 2)
For z = 2 To UBound(arr, 1)
If arr(z, 2)  "" Then ÜB(arr(z, 1)) = arr(z, 2)
Next
Next
'--- fehlende Übersetzungen bei Duplikattexten ergänzen
For Each sh In ActiveWorkbook.Worksheets
With sh.UsedRange.Columns(4).Resize(, 2)
arr = .Value
For z = 2 To UBound(arr, 1)
If arr(z, 2) = "" Then
If ÜB.exists(arr(z, 1)) Then arr(z, 2) = ÜB(arr(z, 1))
End If
Next z
.Value = arr
End With
Next sh
End Sub

Gruß Daniel

Beliebteste Forumthreads (12 Monate)

Duplikate in Workbook finden und Nachbarzelle kopi

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

194 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Duplikate in Workbook finden und Nachbarzelle kopi

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

194 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