Re-post [VBA] Copy selection to multiple worksheets except two

[emmetje]

Can someone please help me?
In the last part of the code I want to copy a selection from 1 worksheets to all other worksheets except two. But the macro stops at the selection and doesn't copy at all. I get no error message. Can someone please tell me what the correct code should be?

Thx.



Sub VakantiekaartenNaarNieuwJaar()
'
' VakantiekaartenNaarNieuwJaar Macro
'
' Keyboard Shortcut: Ctrl+k
'
'OPEN BESTAND
Workbooks.Open Filename:= _
"LOCATION\2014.xls", _
UpdateLinks:=0
'BEVEILIGING WERKBLADEN OPHEFFEN
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Unprotect Password:="PASSWORD"
Next ws
'
'JAARTAL INVOEREN
'
Sheets("Totaal").Select
Range("B3:G3").Select
ActiveCell.FormulaR1C1 = "2014"
Range("B4").Select
'
'BASISBESTAND OPENEN, BLANCO KAART NAAR HUIDIG BESTAND KOPIEREN EN BASISBESTAND SLUITEN
'
Workbooks.Open Filename:= _
"LOCATION\_Vakantiekaartenbestand 2014.xls"
Windows("_Vakantiekaartenbestand 2014.xls").Activate
Sheets("Blanco kaart").Select
Sheets("Blanco kaart").Copy Before:=Workbooks("2014.xls").Sheets("Totaal")
Windows("_Vakantiekaartenbestand 2014.xls").Activate
Windows("_Vakantiekaartenbestand 2014.xls").Close False
'
'RELEVANTE CELLEN UIT BLANCO KAART KOPIEREN NAAR ALLE WERKBLADEN IN HUIDIG BESTAND
'
Workbooks("2014.xls").Activate
Sheets("Blanco kaart").Activate
Range("Y4:Z10").Select
For Each ws In Workbooks("2014.xls").Worksheets
If ws.Name <> "Blanco kaart" And ws.Name <> "Totaal" Then
Selection.Copy Destination:=ws.Cells(Selection.Row, Selection.Column)
End If
Next
End Sub

 

[BrianMH]

Please use code tags. Can you also tell us exactly what line it stops at? Before you run it is the part that it stops at highlighted in red?

Below is the code tagged and indented.

Sub VakantiekaartenNaarNieuwJaar()
'
' VakantiekaartenNaarNieuwJaar Macro
'
' Keyboard Shortcut: Ctrl+k
'
'OPEN BESTAND
    Workbooks.Open Filename:= _
                   "LOCATION\2014.xls", _
                   UpdateLinks:=0
    'BEVEILIGING WERKBLADEN OPHEFFEN
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        ws.Unprotect Password:="PASSWORD"
    Next ws
    '
    'JAARTAL INVOEREN
    '
    Sheets("Totaal").Select
    Range("B3:G3").Select
    ActiveCell.FormulaR1C1 = "2014"
    Range("B4").Select
    '
    'BASISBESTAND OPENEN, BLANCO KAART NAAR HUIDIG BESTAND KOPIEREN EN BASISBESTAND SLUITEN
    '
    Workbooks.Open Filename:= _
                   "LOCATION\_Vakantiekaartenbestand 2014.xls"
    Windows("_Vakantiekaartenbestand 2014.xls").Activate
    Sheets("Blanco kaart").Select
    Sheets("Blanco kaart").Copy Before:=Workbooks("2014.xls").Sheets("Totaal")
    Windows("_Vakantiekaartenbestand 2014.xls").Activate
    Windows("_Vakantiekaartenbestand 2014.xls").Close False
    '
    'RELEVANTE CELLEN UIT BLANCO KAART KOPIEREN NAAR ALLE WERKBLADEN IN HUIDIG BESTAND
    '
    Workbooks("2014.xls").Activate
    Sheets("Blanco kaart").Activate
    Range("Y4:Z10").Select
    For Each ws In Workbooks("2014.xls").Worksheets
        If ws.Name <> "Blanco kaart" And ws.Name <> "Totaal" Then
            Selection.Copy Destination:=ws.Cells(Selection.Row, Selection.Column)
        End If
    Next
End Sub

 

[emmetje]

Thx. Didn't know...
I must explain better. The code doesn't stop running but ends with no errors. What I see on my screen is that the range of worksheet 'Blanco Kaart' is selected but the copy action isn't executed.

 

[BrianMH]

Not really sure why it wasn't working but it is better to work with objects themselves. You don't really need to be activating and selecting. Try this code.

Sub VakantiekaartenNaarNieuwJaar()
'
' VakantiekaartenNaarNieuwJaar Macro
'
' Keyboard Shortcut: Ctrl+k
'
'OPEN BESTAND
    Dim wb As Workbook
    Dim wb2 As Workbook
    Dim wsCopy As Worksheet
    Dim rCopy As Range
    Set wb = Workbooks.Open(Filename:= _
                   "LOCATION\2014.xls", _
                   UpdateLinks:=0)
    'BEVEILIGING WERKBLADEN OPHEFFEN
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        ws.Unprotect Password:="PASSWORD"
    Next ws
    '
    'JAARTAL INVOEREN
    '
    Sheets("Totaal").Range("B3:G3").FormulaR1C1 = "2014"
    
    '
    'BASISBESTAND OPENEN, BLANCO KAART NAAR HUIDIG BESTAND KOPIEREN EN BASISBESTAND SLUITEN
    '
    Set wb2 = Workbooks.Open("LOCATION\_Vakantiekaartenbestand 2014.xls")
    
    wb2.Sheets("Blanco kaart").Copy Before:=wb.Sheets("Totaal")
    wb2.Close False
    '
    'RELEVANTE CELLEN UIT BLANCO KAART KOPIEREN NAAR ALLE WERKBLADEN IN HUIDIG BESTAND
    '
    
    Set wsCopy = wb.Sheets("Blanco kaart")
    Set rCopy = ws.Range("Y4:Z10")
    For Each ws In wb.Worksheets
        If ws.Name <> "Blanco kaart" And ws.Name <> "Totaal" Then
            rCopy.Copy Destination:=ws.Range("""" & rCopy.Address & """")
        End If
    Next
End Sub

 

[emmetje]

Thx, that looks much better but now the macro stops at line:
Set rCopy = ws.Range("Y4:Z10")

Any idea?

 

[BrianMH]

change that line to

Set rCopy = wsCopy.Range("Y4:Z10")

 

[emmetje]

At some point I just don't see it anymore... I'm sorry...

Next stop is at line:
rCopy.Copy Destination:=ws.Range("""" & rCopy.Address & """")

 

[BrianMH]

I thought you needed quotes.

Change
rCopy.Copy Destination:=ws.Range("""" & rCopy.Address & """")
to
rCopy.Copy Destination:=ws.Range(rCopy.Address)

 

[emmetje]

Thx. Ok. The code is fine now. But... Still no paste action...
Can this have something to do with the fact that Y and Z are merged cells?

 

[BrianMH]

It might be. Try
Set rCopy = wsCopy.Range("Y4:Z10")
to
Set rCopy = wsCopy.Range("Y4:Z10").mergearea