Copy Values if name of sheets in two different workbooks are equal

[Fabbby-San]

Hello everybody,

I have the following problem. The loop in the VBA code shown below works fine besides the fact that EXCEL copies cells from the destination workbook (wbTarget) instead of the ones from the source workbook (ThisWorkbook), as I wanted it to be. I thought I would overcome this problem with the With Command, but unfortunately this does not work and I have no furhter idea how to solve this problem. Any help is appreciated, thank you in advance.

Option Explicit


Sub Import_Basisdatei()


Dim strPath As String, strDataName As String
Dim ws As Worksheet
Dim wbSource As Workbook
Dim wbTarget As Workbook
Dim i As Integer, ws_count As Integer


Application.AskToUpdateLinks = False
Application.AutomationSecurity = msoAutomationSecurityLow
Application.ScreenUpdating = False

strPath = ThisWorkbook.Worksheets("Menu").Range("C52") 'Pfad Zieldatei
strDataName = ThisWorkbook.Worksheets("Menu").Range("C53") 'Name Zieldatei


Set wbTarget = Application.Workbooks.Open(strPath & strDataName, UpdateLinks:=0, ReadOnly:=False)
ws_count = ActiveWorkbook.Worksheets.Count




With ThisWorkbook
For Each ws In Worksheets
For i = 1 To ws_count
If ws.Name = wbTarget.Worksheets(i).Range("N1").Value Then
ws.Range(ws.Cells(25, 3), ws.Cells(25, 17)).Copy
wbTarget.Worksheets(i).Range("C23").PasteSpecial Paste:=xlPasteValues
End If
Next i
Next ws
End With


Application.AskToUpdateLinks = True
Application.AutomationSecurity = msoAutomationSecurityByUI
Application.ScreenUpdating = True

End Sub

kind regards
thank you in advance

[Paul_Hossler]

1. I added CODE tags around your macro you can use the [#] icon to insert them and then paste your macro between

2. Not tested but I guessed -- see the comments

3. Also added an alternate version -- matter of style and personal choice

Option Explicit

Sub Import_Basisdatei()
    Dim strPath As String, strDataName As String
    Dim ws As Worksheet
    Dim wbSource As Workbook          ' Not used
    Dim wbTarget As Workbook
    Dim i As Long, ws_count As Long  '   Use Long

    Application.AskToUpdateLinks = False
    Application.AutomationSecurity = msoAutomationSecurityLow
    Application.ScreenUpdating = False
    
    strPath = ThisWorkbook.Worksheets("Menu").Range("C52") 'Pfad Zieldatei
    strDataName = ThisWorkbook.Worksheets("Menu").Range("C53") 'Name Zieldatei
    
    
    Set wbTarget = Application.Workbooks.Open(strPath & strDataName, UpdateLinks:=0, ReadOnly:=False)
    ws_count = ActiveWorkbook.Worksheets.Count  '   This is wbTarget ??

    With ThisWorkbook
        For Each ws In .Worksheets       '   Add the dot so that Worksheets's parent is ThisWorkbook
            For i = 1 To ws_count
                If ws.Name = wbTarget.Worksheets(i).Range("N1").Value Then
                    ws.Range(ws.Cells(25, 3), ws.Cells(25, 17)).Copy
                    wbTarget.Worksheets(i).Range("C23").PasteSpecial Paste:=xlPasteValues
                End If
            Next i
        Next ws
    End With

    Application.AskToUpdateLinks = True
    Application.AutomationSecurity = msoAutomationSecurityByUI
    Application.ScreenUpdating = True
End Sub

Alternate

Sub Import_Basisdatei_Alt()
    Dim strPath As String, strDataName As String
    Dim ws As Worksheet
    Dim wbTarget As Workbook
    Dim i As Long

    With Application
        .AskToUpdateLinks = False
        .AutomationSecurity = msoAutomationSecurityLow
        .ScreenUpdating = False
    End With
    
    strPath = ThisWorkbook.Worksheets("Menu").Range("C52") 'Pfad Zieldatei
    strDataName = ThisWorkbook.Worksheets("Menu").Range("C53") 'Name Zieldatei
    
    
    Set wbTarget = Application.Workbooks.Open(strPath & strDataName, UpdateLinks:=0, ReadOnly:=False)

    For Each ws In ThisWorkbook.Worksheets
        For i = 1 To wbTarget.Worksheets.Count
            If ws.Name = wbTarget.Worksheets(i).Range("N1").Value Then
                ws.Range(ws.Cells(25, 3), ws.Cells(25, 17)).Copy
                wbTarget.Worksheets(i).Range("C23").PasteSpecial Paste:=xlPasteValues
            End If
        Next i
    Next ws

    With Application
        .AskToUpdateLinks = True
        .AutomationSecurity = msoAutomationSecurityByUI
        .ScreenUpdating = True
    End With
End Sub