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
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
Danke,
funktioniert wie gewünscht.
Hallo, wie sieht der Code aus wenn der 1.Wert der übertragen werden soll in Zeile 4 steht, also mit Überschfiften.
Danke
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
Herzlichen Dank,
da hätte ich selber auch draufkommen können.