Kopier ark til andet Projektmappe

Public Sub CopyToOtherWorkbook()
    Dim objWB As Workbook
    Dim objRange As Worksheet
    Dim strFileName As String
    Dim objWB_Destination As Workbook
    Dim objWS_Destination As Worksheet
    Dim StrPath As String
    On Error GoTo Error_CopyToOtherWorkbook
    Set objRange = ActiveWorkbook.Sheets("Stamdata")
    StrPath = ActiveWorkbook.Sheets("Beregninger").Range("c25")
    If Right(StrPath, 1) <> "\" Then StrPath = StrPath & "\"
    strFileName = ActiveWorkbook.Sheets("Beregninger").Range("c26")


    For Each objWB In Application.Workbooks
        If LCase(objWB.FullName) = LCase(strFileName) Then
            Set objWB_Destination = objWB
            Exit For
        End If
    Next objWB

    If objWB_Destination Is Nothing Then
        If strFileName <> "" Then
            If Dir(strFileName) <> "" Then
                Set objWB_Destination = Workbooks.Open(StrPath & strFileName)
            Else
                MsgBox "Destinationsfilen " & strFileName & " eksisterer ikke.", vbCritical
                GoTo End_Error_CopyToOtherWorkbook
            End If
        End If
    End If

    objRange.Copy After:=Workbooks(strFileName).Sheets(3)
    Application.CutCopyMode = False

End_Error_CopyToOtherWorkbook:
    Set objWB = Nothing
    Set objRange = Nothing
    Set objWB_Destination = Nothing
    Exit Sub

Error_CopyToOtherWorkbook:
    MsgBox "Der er sket en fejl." & vbCr & "Fejl nr.: " & Err.Number & vbCr & "Fejlmeddelelse: " & Err.Description
    Resume End_Error_CopyToOtherWorkbook
End Sub

Hvor har du stående, at det ark der skal kopieres hedder Stamdata?

Set objRange = ActiveWorkbook.Sheets("Stamdata")

objRange.Copy After:=Workbooks(strFileName).Sheets(3)

Jeg får at vide at destinationsfilen ikke findes - Jeg kan se at det rigtige filnavn og sti står i Beregninger C26 og C25 - Hvad kan der være galt?

Det må være her der er noget galt:

If objWB_Destination Is Nothing Then
        If strFileName <> "" Then
            If Dir(strFileName) <> "" Then
                Set objWB_Destination = Workbooks.Open(StrPath & strFileName)
            Else
                MsgBox "Destinationsfilen " & strFileName & " eksisterer ikke.", vbCritical
                GoTo End_Error_CopyToOtherWorkbook
            End If
        End If
    End If

Jeg har prøvet at slette ovenstående, så giver det ingen problemer! Har det nogen værdi at have det med?

Når Arket Stamdata kopieres over får den navnet Stamdata(2) fordi der allerede er et Ark der hedder Stamdata. Den nye Stamdata skal erstatte den gamle. Vær opmærksom på at der er kæder til arket, der skal bibeholdes.

Public Sub CopyToOtherWorkbook()
    Dim objWB As Workbook
    Dim objRange As Range
    Dim objWB_Destination As Workbook
    Dim strFileName As String
    Dim StrPath As String

    'On Error GoTo Error_CopyToOtherWorkbook

    Set objRange = ActiveWorkbook.Sheets("Stamdata").Cells
    StrPath = ActiveWorkbook.Sheets("Beregninger").Range("c25")
    If Right(StrPath, 1) <> "\" Then StrPath = StrPath & "\"
    strFileName = ActiveWorkbook.Sheets("Beregninger").Range("c26")


    For Each objWB In Application.Workbooks
        If LCase(objWB.Name) = LCase(strFileName) Then
            Set objWB_Destination = objWB
            Exit For
        End If
    Next objWB

    If objWB_Destination Is Nothing Then
        If strFileName <> "" Then
            If Dir(strFileName) <> "" Then
                Set objWB_Destination = Workbooks.Open(StrPath & strFileName)
            Else
                MsgBox "Destinationsfilen " & StrPath & strFileName & " eksisterer ikke.", vbCritical
                GoTo End_Error_CopyToOtherWorkbook
            End If
        End If
    End If

    objRange.Copy
    Windows(strFileName).Activate
    Sheets("Stamdata").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                                                  :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                          SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False

End_Error_CopyToOtherWorkbook:
    Set objWB = Nothing
    Set objRange = Nothing
    Exit Sub

Error_CopyToOtherWorkbook:
    MsgBox "Der er sket en fejl." & vbCr & "Fejl nr.: " & Err.Number & vbCr & "Fejlmeddelelse: " & Err.Description
    Resume End_Error_CopyToOtherWorkbook
End Sub

Nu kommer der ingen fejl, men intet i cellerne bliver kopieret over!

Kabbak - Har du opgivet mig :-)

koden virker fint her ???

Den lader jo den workbook, som den kopierer til stå åben, så det er den du ser, når koden er kørt, er det ikke det der forvirrer dig.

Jeg har prøvet at skrive noget i cellerne J6 samt i E27 og E28 hvor jeg også har farvet cellerne. Det kommer ikke med over! Jeg har prøvet at ændre følgende:

objWS_Destination.Range("A1").PasteSpecial xlPasteValues 'Ændret A! til A1
    Application.CutCopyMode = False

Uden held.
Både det ark, som jeg kopier fra og til hedder Stamdata - Kan det være derfor?

"Både det ark, som jeg kopier fra og til hedder Stamdata - Kan det være derfor?"
Det gør de også i min test og uden fejl

Jeg har ændret

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
                          SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                          SkipBlanks:=False, Transpose:=False

til

    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False

..og så virker det. Kan ikke rigtig se forskellen på at tage Værdier og Formater hver for sig og så tage Alt på en gang.

Samtidig har jeg ændret:

Range("A1").Select
til
    Cells.Select
Makroen ser nu sådan ud:

Public Sub CopyToOtherWorkbook()
    Dim objWB As Workbook
    Dim objRange As Range
    Dim objWB_Destination As Workbook
    Dim strFileName As String
    Dim StrPath As String

    On Error GoTo Error_CopyToOtherWorkbook

    Set objRange = ActiveWorkbook.Sheets("Stamdata").Cells
    StrPath = ActiveWorkbook.Sheets("Beregninger").Range("c25")
    If Right(StrPath, 1) <> "\" Then StrPath = StrPath & "\"
    strFileName = ActiveWorkbook.Sheets("Beregninger").Range("c26")


    For Each objWB In Application.Workbooks
        If LCase(objWB.Name) = LCase(strFileName) Then
            Set objWB_Destination = objWB
            Exit For
        End If
    Next objWB

    If objWB_Destination Is Nothing Then
        If strFileName <> "" Then
            If Dir(strFileName) <> "" Then
                Set objWB_Destination = Workbooks.Open(StrPath & strFileName)
            Else
                MsgBox "Destinationsfilen " & StrPath & strFileName & " eksisterer ikke.", vbCritical
                GoTo End_Error_CopyToOtherWorkbook
            End If
        End If
    End If
       
    'Kopier alle celler i ObjRange
    objRange.Copy
        Windows(strFileName).Activate
    Sheets("Stamdata").Select
   
    'Vælger alle celler i Stamdata
    Cells.Select
   
    'Indsætter alt fra Stamdataprojektmappen - Ark Stamdata i nye Ark Stamdata
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False

End_Error_CopyToOtherWorkbook:
    Set objWB = Nothing
    Set objRange = Nothing
    Exit Sub

Error_CopyToOtherWorkbook:
    MsgBox "Der er sket en fejl." & vbCr & "Fejl nr.: " & Err.Number & vbCr & "Fejlmeddelelse: " & Err.Description
    Resume End_Error_CopyToOtherWorkbook
End Sub

Og det virker!

Kabbak smid et svar!

Godt du fik det til at virke, jeg kan heller ikke se forskellen, tag nogen point selv, da du selv ordnede resten. ;-))

OK