Printout in a loop, keep getting same

[MichaelTigers]

Hi,I have used below code to fill certain OLEObjects in a loop:Dim rng As RangeDim wsS As WorksheetDim wsD As WorksheetActiveSheet.Copy after:=Sheets(Sheets.Count)Sheets(Sheets.Count).Name = "Sourcebook"Set wsS = Sheets("Sourcebook")Set wsD = Sheets("CMR")Set rng = wsS.Range("A3", Range("A100").End(xlUp))Answer = MsgBox("Je print nu alle CMR's!", vbOKCancel, "Generate CMR") If Answer = vbCancel Then Exit Sub End If wsD.Visible = True For Each rng In wsS.Range("A3", Range("A2").End(xlDown)) wsD.Activate With ActiveSheet .OLEObjects("Shipper").Object.Text = "Ref: " & rng.Offset(0, 9).Value .OLEObjects("Consignee").Object.Text = rng.Offset(0, 0).Value & vbNewLine & _ rng.Offset(0, 11).Value & vbNewLine & _ rng.Offset(0, 12).Value & " " & rng.Offset(0, 13).Value & vbNewLine & _ rng.Offset(0, 14).Value .OLEObjects("Delivery").Object.Text = rng.Offset(0, 12).Value & " " & rng.Offset(0, 13).Value & ", " & rng.Offset(0, 14).Value .OLEObjects("Reference").Object.Text = "" & vbNewLine & _ "" & vbNewLine & _ "" & vbNewLine & _ "" & vbNewLine & _ "ref:" & vbNewLine & _ rng.Offset(0, 9).Value .OLEObjects("Unit").Object.Text = rng.Offset(0, 7).Value .OLEObjects("Description").Object.Text = "Iron ware" & vbNewLine & rng.Offset(0, 6).Value .OLEObjects("Weight").Object.Text = rng.Offset(0, 8).Value .OLEObjects("Code").Object.Text = " Pallet code: " & rng.Offset(0, 15).Value .OLEObjects("Place").Object.Text = rng.Offset(0, 13).Value End With wsD.PrintOut From:=1, To:=1, Copies:=4, preview:=True, ActivePrinter:="\\RTM5\Xerox WorkCentre 7845 CMR" Next rngNow the problem is that I keep getting the same document several times when I run this. While if I go through step by step (F8) it works.Does anyone has the solution for this?Kind regards,