simple - CODE NEEDS TWEAKED - copy/paste for archive

[HELP PLEASE]

The code below copies cells A:Q from Sheet1 and pastes them in their appropriate worksheet (titled Jan-05, Feb-05, Mar-05, etc.) based on the month of their entry. Can someone help me to tweak this code so that when the info is pasted into the appropriate month sheet that it only pastes into columns A:Q? Now it does paste in A:Q but it also wipes out entries in columns R on. Thanks so much!


Option Explicit

'** Turn off events and make it look a little nicer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'** Declare variables to use
Dim ws As String, masterWs As Worksheet, copyRng As Range
'Master Worksheet variables
Dim i As Long, lastRow As Long, wsRow As Long
'Number (row/iteration) variables
Dim lookRng As Range, foundRng As Long, myVal As String
'worksheet variables, for duplicates
Dim wf, n As Long
'** Set master worksheet variables
'-------------------------------------------------------------------
Set masterWs = Sheets("Sheet1") 'ALTERED
'-------------------------------------------------------------------
Set wf = Application.WorksheetFunction 'ADDED
lastRow = masterWs.Range("A65536").End(xlUp).Row
With masterWs
'** Start loop/iteration through all values in master ws col A
For i = 2 To lastRow Step 1
'** Make sure it isn't blank
If .Range("A" & i).Value = "" Then Exit For
'** Use value in col A as a sheetname variable
'** NOTE: Will error out with this variable if it does not match
' an actual sheet! There is currently no error handling for this!

ws = .Range("A" & i).Text
myVal = .Range("L" & i).Text
' If LCase(.Range("Q" & i).Value) = "X" Then GoTo SkipMe
'** Set the range to copy
Set copyRng = .Range("A" & i & ":Q" & i)
'** Set the range to check for duplicates in worksheets
Set lookRng = Sheets(ws).Range("L:L")
'Look for duplicates
'-------------------------------------------------------------------
foundRng = wf.CountIf(lookRng, myVal)
'-------------------------------------------------------------------
'** Checking if ID number has been found or not
If foundRng > 0 Then
'ID Number is already there
For n = 1 To Sheets(ws).Range("A65536").End(xlUp).Row Step 1
If Sheets(ws).Range("B" & n).Text = myVal Then Exit For
Next n
Sheets(ws).Range("A" & n).EntireRow.Delete
'** Get the last row of the target sheet (value of col A)
wsRow = Sheets(ws).Range("A65536").End(xlUp).Row + 1
.Range("A" & i & ":Q" & i).Copy
'-------------------------------------------------------------------
Sheets(ws).Range("A" & wsRow).PasteSpecial (xlPasteValues)
Sheets(ws).Range("A" & wsRow).PasteSpecial (xlPasteFormats)
'-------------------------------------------------------------------
Else
'ID Number is NOT there
'** Get the last row of the target sheet (value of col A)
wsRow = Sheets(ws).Range("A65536").End(xlUp).Row + 1
.Range("A" & i & ":Q" & i).Copy
'-------------------------------------------------------------------
Sheets(ws).Range("A" & wsRow).PasteSpecial (xlPasteValues)
Sheets(ws).Range("A" & wsRow).PasteSpecial (xlPasteFormats)
'-------------------------------------------------------------------
End If

SkipMe:
Next i
End With
'** Turn events back on to normal status
Application.DisplayAlerts = True
Application.ScreenUpdating = True


End Sub

 

[joelnichols]

Just a thought..replace

Sheets(ws).Range("A" & wsRow).PasteSpecial (xlPasteValues)
Sheets(ws).Range("A" & wsRow).PasteSpecial (xlPasteFormats)

with

Sheets(ws).Range("A1").PasteSpecial (xlPasteValues)
Sheets(ws).Range("A1).PasteSpecial (xlPasteFormats)

See if that works out