Friday, July 29, 2011

Copy Data WithOut Decimal Value :

If you want to Copy your date with out Decimal Value You can use this Code :



Option Base 1
Sub CopyPasteWithOutDecimalPlace()




Dim rngCopy As Range
Dim rngPaste As Range
Dim arr() As String
Dim cell As Range
Dim iVal As String
Dim Rw As Integer
Dim Col As Integer
Dim cellvalue As Variant


        Set rngCopy = Application.InputBox("Select the Range to Copy ", , , , , , , 8)
        Set rngPaste = Application.InputBox("Select A cell to Paste the Data", , , , , , , 8)


                ReDim arr(1 To rngCopy.Rows.Count, 1 To rngCopy.Columns.Count)
                        Rw = rngCopy.Rows.Count
                        Cl = rngCopy.Columns.Count
                                        
                       Application.ScreenUpdating = False
                       
                        For r = 1 To Rw
                            For c = 1 To Cl
                                cellvalue = rngCopy.Cells(r, c).Value
                                If WorksheetFunction.IsNumber(rngCopy.Cells(r, c).Value) Then
                                        iVal = Left(cellvalue, WorksheetFunction.Find(".", cellvalue, 1) - 1)
                                        arr(r, c) = iVal
                                    ElseIf IsError(cellvalue) Then
                                            arr(r, c) = CStr(cellvalue)
                                    Else
                                        arr(r, c) = cellvalue
                                End If
                            Next
                        Next




                        
                        rngPaste.Resize(Rw, Cl).Value = arr
                        rngPaste.Resize(Rw, Cl).Value = rngPaste.Resize(Rw, Cl).Value
                        Application.ScreenUpdating = True
End Sub




No comments: