Hallo,
um die zusätzlichen Inhalte kopieren zu können muss die Sub ausgetauscht werden:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim strFilename As String
Dim strValue As String
Dim wbk As Workbook
Dim rng As Range
Set rng = refersToRange("Buttons")
If Not Intersect(rng, Target) Is Nothing Then
strFilename = ThisWorkbook.Path & "\autoFile_2.xlsm"
Set wbk = GetWorkbook(strFilename)
If wbk Is Nothing Then
Set wbk = Application.Workbooks.Open(filename:=strFilename)
Else
wbk.Activate
End If
' B18 <- A3:A502
strValue = Target.Cells(1, 1).Value
If Not strValue = "" Then
wbk.Worksheets(1).Range("B18").Value = strValue
End If
' B11 <- E3:E502
strValue = Target.Cells(1, 1).Offset(columnOffset:=4).Value
If Not strValue = "" Then
wbk.Worksheets(1).Range("B11").Value = strValue
End If
' B12 <- F3:F502
strValue = Target.Cells(1, 1).Offset(columnOffset:=5).Value
If Not strValue = "" Then
wbk.Worksheets(1).Range("B12").Value = strValue
End If
' G10 <- G3:G502
strValue = Target.Cells(1, 1).Offset(columnOffset:=6).Value
If Not strValue = "" Then
wbk.Worksheets(1).Range("G10").Value = strValue
End If
' B9 <- H3:H502
strValue = Target.Cells(1, 1).Offset(columnOffset:=7).Value
If Not strValue = "" Then
wbk.Worksheets(1).Range("B9").Value = strValue
End If
' --> Weitere zu kopierende Inhalte müssen hier eingesetzt werden <--
End If
End Sub
Bei Bedarf muss wieder der Pfad und Dateiname zu der nachzuladenden Arbeitsmappe angepasst werden.
Falls noch weitere Inhalte nach dem gleichen Muster in eine andere Zelle der nachzuladenden Arbeitsmappe kopiert werden sollen, müssen lediglich die nachstehenden Zeilen angepast und unter die bestehenden Zeilen hinzugefügt werden:
Bsp: Inhalte der Zeilen K3-K502 sollen in die Zelle H3 kopiert werden:
' H3 <- K3:K502
strValue = Target.Cells(1, 1).Offset(columnOffset:=10).Value
If Not strValue = "" Then
wbk.Worksheets(1).Range("H3").Value = strValue
End If
LG, BigBen
|