Glad you got it working

You say you need to include "wsDest.Cells(r, c).Select"

I assume ? you've also kept these original lines just a little earlier in
the code -

wsDest.Activate
wsDest.Cells(r, c).Activate

Not sure why the new line helps, seems to duplicate what's already done, but
if it does keep it!

you can peruse my code below and maybe see what may be
wrong with it.

I can't test without recreating your workbook, which I can't, and would take
a long time to see what's wrong - you haven't given a clue as to why you
think it is wrong.
However you've got a lot going on there and would strongly recommend you
break it down in to a number of Subs or Functions, passing variables between
them as necessary. You may then find it much easier to debug yourself. Set a
few break points, look at what's going on, query any variables by ? in the
immediate window or by setting Watches.

Regards,
Peter T

"justme" wrote in message
...
Hi Peter!

Thank you thank you thank you for all your help! As for the picture
problem, I HAD originally adapted it for my own workbook, but when I
couldn't
get it working, I deleted it, so I just copied your original posted code
into
my question.

So, I followed your picture "manual test" and after that, magically the
code
worked when i ran it again. But later on, my sub was doing the same thing
with the pictures, pasting pics starting from cell A1. I don't know what
is
wrong with my code, but I seem to have stabilized it for now by replacing.


wsSource.Pictures.Copy
wsDest.Paste

with

wsSource.Pictures.Copy
wsDest.Cells(r, c).Select
wsDest.Paste

I don't know, why, but it's working for now. Thanks so much!!

If you feel like it, you can peruse my code below and maybe see what may
be
wrong with it. I am really not a programming, just painstakingly patching
stuff together one by one...
:)


Public Sub WT_CreateForms()
'
' Creates individual fitter sheets with fitter-specific data from master
fitter sheet and renames all sheets

On Error GoTo ErrorHandler

'General
Dim MFS As Worksheet
Dim FST As Worksheet
Dim FTRS As Worksheet
Dim WTSS As Worksheet
Dim CFS As Worksheet 'Current Fitter Sheet

Set MFS = ActiveWorkbook.Sheets("MasterFitterSurvey")
Set FST = ActiveWorkbook.Sheets("fsTemplate")
Set FTRS = ActiveWorkbook.Sheets("Fitters")
Set WTSS = ActiveWorkbook.Sheets("WearTestSurveySheet")

'Fitters
Dim iRow As Long
Dim myRange As Range, Cell As Range

'Sheet Naming
Dim myDate As String
Dim myStyle As String
Dim myFitter As String
Dim SheetName As String
Dim TestType As String

TestType = MFS.Cells(10, 17).Text
myStyle = MFS.Cells(5, 4).Text

'Input Date For Sheet Names
Do While myDate = vbNullString
myDate = Application.InputBox(Prompt:="Please Enter Today's Date as
YYMMDD",
Type:=2, Default:=Format(Date, "yymmdd"))
If myDate = vbNullString Then
MsgBox ("You must enter a Date as YYMMDD or Cancel; please try again")
End If
Loop
If myDate = "False" Then 'user pressed cancel
FTRS.Select
Exit Sub
End If


'START LOOP
'Move First Fitter Into Position
FTRS.Activate
For iRow = 6 To FTRS.Cells(FTRS.Rows.Count, "A").End(xlUp).Row
FTRS.Range("A" & iRow, "AH" & iRow).Select
Selection.RowHeight = 13
Selection.Copy

FTRS.Range("A3", "AH3").Select
ActiveSheet.Paste
Selection.RowHeight = 13






'CREATE NEW FITTER SHEETS
'Copy FST fitter template containing change event code

myFitter = Left(FTRS.Cells(3, 3).Text, 6) & Left(FTRS.Cells(3, 4).Text, 1)
FST.Copy After:=Sheets(ActiveWorkbook.Sheets.Count)
SheetName = myDate & "_" & myStyle & "_" & TestType & "_FSH_" & myFitter
Sheets(ActiveWorkbook.Sheets.Count).Name = SheetName
Set CFS = ActiveSheet

'Copy MFS Information to New Worksheet
MFS.Activate
With MFS
Cells.Select
Selection.Copy
End With

'Paste MFS Information to New Worksheet
CFS.Activate
With CFS.Range("A1")
.PasteSpecial xlPasteValuesAndNumberFormats
.PasteSpecial xlFormats
.PasteSpecial xlPasteValidation
.PasteSpecial xlPasteComments
End With


'Format unfillled fitter info to turn green when filled in
With CFS
Set myRange = .Range(.Cells(15, "E"), .Cells(16, "E")) '''Variable
cell
Reference
For Each Cell In myRange
If Cell.Value Like "Please*" Then
Cell.Font.ColorIndex = 4
Cell.Font.Italic = False
End If
Next Cell
End With
With CFS
Set myRange = .Range(.Cells(20, "K"), .Cells(22, "K")) '''Variable
Cell
Reference
For Each Cell In myRange
If Cell.Value Like "Please*" Then
Cell.Font.ColorIndex = 4
Cell.Font.Italic = False
End If
Next Cell
End With

'Edit Filled-in Fitter info cells in E15 and E16 & K20-k22 to induce
worksheet change event merged cell autofit sub
With CFS
Set myRange = .Range(.Cells(15, "E"), .Cells(16, "E")) '''Variable
cell
Reference
For Each Cell In myRange
If Not Cell.Value Like "Please*" Then
Cell.Value = Cell & ".."
Cell.Value = Left(Cell.Value, Len(Cell.Value) - 2)
End If
Next Cell
End With
With CFS
Set myRange = .Range(.Cells(20, "K"), .Cells(22, "K")) '''Variable
Cell
Reference
For Each Cell In myRange
If Not Cell.Value Like "Please*" Then
Cell.Value = Cell & ".."
Cell.Value = Left(Cell.Value, Len(Cell.Value) - 2)
End If
Next Cell
End With

'MFS.Activate
'Range("A1").Select
'CFS.Activate
'Range("A1").Select


'Copy all pictures to new Fitter Sheet
MFS.Activate

Dim r As Long, c As Long
Dim pic As Picture

r = MFS.Rows.Count
c = MFS.Columns.Count

For Each pic In MFS.Pictures
With pic.TopLeftCell
If .Row < r Then r = .Row
If .Column < c Then c = .Column
End With
Next

CFS.Activate
CFS.Cells(r, c).Activate

MFS.Pictures.Copy
CFS.Cells(r, c).Select
CFS.Paste

CFS.Cells(1, 1).Activate
Set CFS = Nothing

FTRS.Activate
Next iRow


'RENAME FTRS
FTRS.Select
SheetName = myDate & "_" & myStyle & "_" & TestType & "_FTRS"
FTRS.Name = SheetName

'RENAME MFS
MFS.Select
SheetName = myDate & "_" & myStyle & "_" & TestType & "_MFS"
MFS.Name = SheetName

'RENAME WTSS
WTSS.Select
SheetName = myDate & "_" & myStyle & "_" & TestType & "_SS"
WTSS.Name = SheetName

'Save Workbook
ActiveWorkbook.SaveAs Filename:="C:\Documents and Settings\Marib\My
Documents\0- Wear Testing\Projects\" & SheetName & ".xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="",
ReadOnlyRecommended:=False, CreateBackup:=False

SheetName = ""

ErrorHandlerNext:
Exit Sub

ErrorHandler:
'Err.Raise 1001
MsgBox "Error " & Err.Number & "; " & Err.Description
'Resume ErrorHandlerNext

End Sub