PDA

View Full Version : Solved: Code to paste intersheet values only



U_Shrestha
02-28-2008, 12:35 PM
Hello,

I need a little help for the following code. xld had been helping me in this code. Basically, the following code copies and pastes the data from one worksheet to another worksheet. I just want the code to paste the values only instead of pasting the formulas, formats etc. Can someone please help? Thanks.

Private Sub Worksheet_Change(ByVal Target As Range)
Const DestSheet As String = "DataPullUpPage"
Const SourceSheet As String = "AuditIssues"
Dim StationNo As Long
Dim FoundRow As Double
Dim DestRow As Double
Dim iSource As Double, iDest As Double, LastRow As Double

On Error Goto GetIssues_Error

Application.ScreenUpdating = False
Application.EnableEvents = False

If Not Intersect(Target, Me.Range("c2")) Is Nothing Then

' Clear out old data
Me.Range("A12:A" & Me.Rows.Count).EntireRow.Delete

iSource = 2
iDest = 12
LastRow = Sheets(SourceSheet).Range("A" & Me.Rows.Count).End(xlUp).Row

' Find the first occurance of station number on the issues page.
While Sheets(SourceSheet).Cells(iSource, 1) <> Target.Value And iSource <= LastRow
iSource = iSource + 1
Wend

' If the station isn't found, exit
If iSource >= LastRow Then
MsgBox "Station Number does not exist"

Else

' Copy selected cells to the destination sheet
' Copy selected cells to the destination sheet
While Worksheets(SourceSheet).Cells(iSource, 1) = Target.Value
Sheets(SourceSheet).Range("C" & iSource & ":M" & iSource).Copy _
Me.Range("A" & iDest)
iSource = iSource + 1
iDest = iDest + 1
Wend
End If
End If

MyEnd:
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub

GetIssues_Error:
Resume MyEnd
End Sub

Bob Phillips
02-28-2008, 12:56 PM
Private Sub Worksheet_Change(ByVal Target As Range)
Const DestSheet As String = "DataPullUpPage"
Const SourceSheet As String = "AuditIssues"
Dim StationNo As Long
Dim FoundRow As Double
Dim DestRow As Double
Dim iSource As Double, iDest As Double, LastRow As Double

On Error GoTo GetIssues_Error

Application.ScreenUpdating = False
Application.EnableEvents = False

If Not Intersect(Target, Me.Range("B2")) Is Nothing Then

' Clear out old data
Me.Range("A13:A" & Me.Rows.Count).EntireRow.Delete

iSource = 2
iDest = 13
LastRow = Sheets(SourceSheet).Range("A" & Me.Rows.Count).End(xlUp).Row

' Find the first occurance of station number on the issues page.
While Sheets(SourceSheet).Cells(iSource, 1) <> Target.Value And iSource <= LastRow

iSource = iSource + 1
Wend

' If the station isn't found, exit
If iSource >= LastRow Then
MsgBox "Station Number does not exist"

Else

' Copy selected cells to the destination sheet
' Copy selected cells to the destination sheet
While Worksheets(SourceSheet).Cells(iSource, 1) = Target.Value

Sheets(SourceSheet).Range("C" & iSource & ":M" & iSource).Copy
Me.Range("A" & iDest).PasteSpecial Paste:=xlValues
iSource = iSource + 1
iDest = iDest + 1
Wend

Me.Rows(13).Resize(iDest - 12).WrapText = False
End If
End If

MyEnd:
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub

GetIssues_Error:
Resume MyEnd
End Sub

U_Shrestha
02-28-2008, 01:24 PM
xld: You gave me exactly what I asked but I am sorry, I do need to keep the format. The reason I requested for code updated was because I was getting circular reference error as when that code copied data it copied formulas also and it was giving me circular reference error. Can you please edit the code so that the values and formats are copied. Those are the only two things I need, it also includes the cells borders. If you notice in my last attachment, when I ran the macro it outlined the cell borders also.

I would really appreciate your help . Thanks.

Norie
02-28-2008, 01:33 PM
umesh

In your first post you stated you just wanted values.

You now appear to be saying you want to keep the formatting.

Please clarify.

U_Shrestha
02-28-2008, 01:40 PM
Yes, I want the values and the formatting. Formatting should include the colors and borders of the cells being copied.

I do not want the formulas as it caused circular reference error. Sorry for the confusion.

U_Shrestha
02-28-2008, 02:26 PM
The following code worked. It pastes the value and the formatting. Thanks xld. :)

Private Sub Worksheet_Change(ByVal Target As Range)
Const DestSheet As String = "DataPullUpPage"
Const SourceSheet As String = "AuditIssues"
Dim StationNo As Long
Dim FoundRow As Double
Dim DestRow As Double
Dim iSource As Double, iDest As Double, LastRow As Double

On Error GoTo GetIssues_Error

Application.ScreenUpdating = False
Application.EnableEvents = False

If Not Intersect(Target, Me.Range("c2")) Is Nothing Then

' Clear out old data
Me.Range("A12:A" & Me.Rows.Count).EntireRow.Delete

iSource = 2
iDest = 12
LastRow = Sheets(SourceSheet).Range("A" & Me.Rows.Count).End(xlUp).Row

' Find the first occurance of station number on the issues page.
While Sheets(SourceSheet).Cells(iSource, 1) <> Target.Value And iSource <= LastRow

iSource = iSource + 1
Wend

' If the station isn't found, exit
If iSource >= LastRow Then
MsgBox "Station Number does not exist"

Else

' Copy selected cells to the destination sheet
' Copy selected cells to the destination sheet
While Worksheets(SourceSheet).Cells(iSource, 1) = Target.Value

Sheets(SourceSheet).Range("C" & iSource & ":M" & iSource).Copy
Me.Range("A" & iDest).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Me.Range("A" & iDest).PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
iSource = iSource + 1
iDest = iDest + 1
Wend

End If
End If

MyEnd:
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub

GetIssues_Error:
Resume MyEnd
End Sub