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
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:
Post a Comment