Makro statt sverweis

[amigo9876]

Hallo!
Kann mir bitte jemand helfen.
Ich möchte mit einem Makro von Mappe1 die Spalte D, dem gleichen Namen in Mappe 2 in Spalte E übertragen.
Kann mir jemand den Code mitteilen.

Danke

[volti]

Hallo Amigo,

hier mal ein Vorschlag in klassischer Form zu Deinem Anliegen.

Probier's mal aus ob's in Deinem Sinne funktioniert.

Code:

Option Explicit

Sub Daten_Uebertragen()
'Annahme: Beiden Mappen sind geöffnet
 Dim iZeile As Long, iGefunden As Long
 Dim WShZ As Worksheet
 
'Festlegen der Ziel-Mappe
 Set WShZ = Workbooks("Mappe2.xlsx").Sheets("Tabelle1")
 
 With Application
  .ScreenUpdating = False
  .Calculation = xlCalculationManual
 
'Beginn der Übertragung (ohne Überschrift)
  With Workbooks("Mappe1.xlsx").Sheets("Tabelle1")
    On Error Resume Next
    For iZeile = 1 To .UsedRange.Rows.Count
      iGefunden = Application.WorksheetFunction.Match( _
                  .Cells(iZeile, "A").value, WShZ.Range("A:A"), 0)
      If Not IsError(iGefunden) Then
         WShZ.Cells(iGefunden, "E").value = .Cells(iZeile, "D").value
      End If
    Next iZeile
  End With

  .ScreenUpdating = True
  .Calculation = xlCalculationAutomatic
 End With

End Sub

____________________

viele Grüße aus Freigericht
Karl-Heinz

[amigo9876]

Danke,
funktioniert wie gewünscht.

[amigo9876]

Hallo, wie sieht der Code aus  wenn der 1.Wert der übertragen werden soll in Zeile 4 steht, also mit Überschfiften.
Danke

[volti]

Na da brauchst Du doch lediglich bei iZeile=4 anfangen:

Code:

Option Explicit

Sub Daten_Uebertragen()
'Annahme: Beiden Mappen sind geöffnet
 Dim iZeile As Long, iGefunden As Long
 Dim WShZ As Worksheet
 
'Festlegen der Ziel-Mappe
 Set WShZ = Workbooks("Mappe2.xlsx").Sheets("Tabelle1")
 
 With Application
  .ScreenUpdating = False
  .Calculation = xlCalculationManual
 
'Beginn der Übertragung (ohne Überschrift)
  With Workbooks("Mappe1.xlsx").Sheets("Tabelle1")
    On Error Resume Next
    For iZeile = 4 To .UsedRange.Rows.Count
      iGefunden = Application.WorksheetFunction.Match( _
                  .Cells(iZeile, "A").Value, WShZ.Range("A:A"), 0)
      If Not IsError(iGefunden) Then
         WShZ.Cells(iGefunden, "E").Value = .Cells(iZeile, "D").Value
      End If
    Next iZeile
  End With

  .ScreenUpdating = True
  .Calculation = xlCalculationAutomatic
 End With

End Sub

____________________

viele Grüße aus Freigericht
Karl-Heinz

[amigo9876]

Herzlichen Dank,

da hätte ich selber auch draufkommen können.