AW: Link auf Beispieldatei fehlt! o.T.
24.04.2017 13:13:45
Matthias
Moin! Also so könntest du die Spaltennamen zuordnen. Im array am Anfang mal zuordnen, wie die Spalten heißen sollen. Der Erste Eintrag ist immer der aus der Mappe gewicht (also wb2) und dahinter gleich der aus der aktuellen Mappe (wb1). So wie du die WErte hinschreibst wird auch eingetragen. So kannst du also auch festlegen, welche Spalte aus Gewicht in welche Spalte in der aktuellen Mappe soll. VG
Sub Transfer()
Dim i As Long, lastrow As Long, findZeile As Long
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim treffer As Object
Dim zwei As Long
Dim eins As String
Dim anzahl As Long
Dim namen()
Dim index()
Dim bezug As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'hier die Zuordnung eintragen, erst den namen der Überschrift aus wb2 und dann das Gegenstück _
hier
namen = Array("gew1", "gewicht1", "gew2", "gewicht2", "gew3", "gewicht3")
anzahl = UBound(namen)
Set wb1 = ThisWorkbook
Set ws1 = wb1.Sheets(1)
Set wb2 = Workbooks.Open("C:\Desktop\Gewicht.xlsx")
Set ws2 = wb2.Sheets(1)
ReDim Preserve index(anzahl)
'Zuordnung finden
For i = 0 To anzahl Step 2
Set treffer = ws2.Rows(1).Find(namen(i), LookIn:=xlValues)
If Not treffer Is Nothing Then
index(i) = treffer.Column
Else
MsgBox "Die Spaltenummer wurde nicht gefunden! Programmende"
Exit Sub
End If
Set treffer = ws1.Rows(1).Find(namen(i + 1), LookIn:=xlValues)
If Not treffer Is Nothing Then
index(i + 1) = treffer.Column
Else
MsgBox "Der Spaltename wurde nicht gefunden! Programmende"
Exit Sub
End If
Next i
ws1.Columns("CQ:CR").NumberFormat = "0"
lastrow = ws2.Range("C" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
Set treffer = ws1.Columns(3).Find(CStr(ws2.Cells(i, 3)), LookIn:=xlValues)
If Not treffer Is Nothing Then
findZeile = treffer.Row
For bezug = 0 To anzahl Step 2
ws1.Cells(findZeile, index(bezug + 1)) = CDbl(ws2.Cells(i, CDbl(index(bezug))))
Next bezug
End If
Set treffer = Nothing
Next i
wb2.Close savechanges:=True
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub