Inhalte gemäß Liste austauschen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

nur wenige schauen auf Deinen Rechner und sehen die Datei.
Ich möchte gerne den Fehler im Original sehen.
Ich baue keine Datei nach. Die Zeit hat schon jemand investiert.
Ein Nachbau sieht meist anders aus als das Original. Darum sollte das Original verlinkt werden.
Wenn du an Stelle einer Demomappe deine Originalmappe hochladen willst, diese aber sensible Daten enthält, kannst du diese Daten anonymisieren bzw. pseudonymisieren.

Ich gebe keinen Dank für eine Rückmeldung, da ich durch solche Beiträge nicht meine Beitragszahl erhöhen muss.
Rückmeldung ist ja in der Heutigen Zeit nicht üblich und die wenigen die eine Rückmeldung geben, mögen mir das verzeihen, das kein Danke für eine Rückmeldung kommt.

Option Explicit Sub Ersetzen() Dim LoLetzte As Long Dim LoI As Long Dim Rafound1 As Range LoLetzte = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows. _ Count) For LoI = 1 To LoLetzte With Worksheets("Tabelle2") If Cells(LoI, 1) "" Then Set Rafound1 = .Columns(1).Find(Cells(LoI, 1), Range("A" & Rows.Count), _ xlFormulas, _ xlPart, , xlNext) If Not Rafound1 Is Nothing Then If InStr(Rafound1, "--") > 0 Then Cells(LoI, 1) = Mid(Rafound1, InStr(Rafound1, "--") + 2) End If End If End If End With Next LoI End Sub

' ********************************************************************** ' Modul: Modul1 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Const cstrPath As String = "E:\Forum\" 'Pfad von Date2 Const cstrFile As String = "Datei2.xlsx" 'Name von Datei2 Const cstrTable As String = "Tabelle2" 'Tabelle in Datei2 Sub replaceNames() Dim strRef As String, rng As Range, rngC As Range strRef = "'" & cstrPath & "[" & cstrFile & "]" & cstrTable & "'!" With Sheets("Tabelle1") Set rng = .Range("A2:A" & Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)) For Each rngC In rng rngC.Formula = "=IFERROR(INDEX(" & strRef & "B:B,MATCH(""" & rngC.Value & """," & strRef & "A:A,0)), """ & rngC.Value & """)" Next rng = rng.Value End With End Sub Sub replaceNames2() Dim strRef As String, rng As Range, rngC As Range strRef = "'" & cstrPath & "[" & cstrFile & "]" & cstrTable & "'!" With Sheets("Tabelle1") Set rng = .Range("A2:A" & Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)) For Each rngC In rng rngC.Formula = "=IFERROR(INDEX(" & strRef & "A:A,MATCH(""" & rngC.Value & """," & strRef & "B:B,0)), """ & rngC.Value & """)" Next rng = rng.Value End With End Sub

' ********************************************************************** ' Modul: Modul1 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Const cstrPath As String = "E:\Forum\" 'Pfad von Date2 Const cstrFile As String = "Datei2.xlsx" 'Name von Datei2 Const cstrTable As String = "Tabelle2" 'Tabelle in Datei2 Sub replaceNames() Dim strRef As String, rng As Range, rngC As Range strRef = "'" & cstrPath & "[" & cstrFile & "]" & cstrTable & "'!" With Sheets("Tabelle1") Set rng = .Range("A2:A" & Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)) For Each rngC In rng rngC.Formula = "=IFERROR(INDEX(" & strRef & "B:B,MATCH(""" & rngC.Value & """," & _ strRef & "A:A,0)), IFERROR(INDEX(" & strRef & "A:A,MATCH(""" & rngC.Value & """," & _ strRef & "B:B,0)), """ & rngC.Value & """))" Next rng = rng.Value End With End Sub

Hallo nochmal,
eine schnellere Variant bei vielen Daten.

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Const cstrPath As String = "E:\Forum\"    'Pfad von Datei2
Const cstrFile As String = "Datei2.xlsx"  'Name von Datei2
Const cstrTable As String = "Tabelle2"    'Tabelle in Datei2

Sub replaceNamesII()
Dim objWB As Workbook, objOpen As Workbook, rng As Range, bolOpen As Boolean
Dim varValues As Variant, lngIndex As Long, varRet As Variant

On Error GoTo ErrExit

Application.ScreenUpdating = False

If Dir(cstrPath & cstrFile, vbNormal) <> "" Then
  With Sheets("Tabelle1")
    Set rng = .Range("A2:A" & Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row))
    varValues = rng
  End With
  
  For Each objOpen In Application.Workbooks
    If objOpen.FullName = cstrPath & cstrFile Then
      Set objWB = objOpen
      bolOpen = True
      Exit For
    End If
  Next
  
  If objWB Is Nothing Then Set objWB = Workbooks.Open(cstrPath & cstrFile)
  
  With objWB.Sheets(cstrTable)
    For lngIndex = 1 To UBound(varValues, 1)
      varRet = Application.Match(varValues(lngIndex, 1), .Columns(1), 0)
      If IsNumeric(varRet) Then
        varValues(lngIndex, 1) = .Cells(varRet, 2)
      Else
        varRet = Application.Match(varValues(lngIndex, 1), .Columns(2), 0)
        If IsNumeric(varRet) Then
          varValues(lngIndex, 1) = .Cells(varRet, 1)
        End If
      End If
    Next
  End With
  
  If Not bolOpen Then objWB.Close False
  
  rng = varValues
End If

ErrExit:

Application.ScreenUpdating = True

Set objWB = Nothing
Set rng = Nothing
End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Inhalte gemäß Liste austauschen

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread