copy and past from one sheet to another help

%3CLINGO-SUB%20id%3D%22lingo-sub-1285810%22%20slang%3D%22en-US%22%3Ecopy%20and%20past%20from%20one%20sheet%20to%20another%20help%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-1285810%22%20slang%3D%22en-US%22%3E%3CP%3EI%20have%20this%20code%20and%20it%20works%20great%20for%20what%20I%20need%20except%20I%20would%20like%20it%20to%20select%20the%20same%20copy%20column%20and%20same%20paste%20cell%20everytime.%20rather%20than%20me%20having%20to%20select%20it%20everytime.%20please%20help%3C%2FP%3E%3CP%3ESub%20CopyRow()%3CBR%20%2F%3E'Updateby%20Extendoffice%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%20Dim%20xRgS%20As%20Range%2C%20xRgD%20As%20Range%2C%20xCell%20As%20Range%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%20Dim%20I%20As%20Long%2C%20xCol%20As%20Long%2C%20J%20As%20Long%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%20Dim%20xVal%20As%20Variant%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%20On%20Error%20Resume%20Next%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%20Set%20xRgS%20%3D%20Application.InputBox(%22Please%20select%20the%20date%20column%3A%22%2C%20%22KuTools%20For%20Excel%22%2C%20Selection.Address%2C%20%2C%20%2C%20%2C%20%2C%20%3CLI-EMOJI%20id%3D%22lia_smiling-face-with-sunglasses%22%20title%3D%22%3Asmiling_face_with_sunglasses%3A%22%3E%3C%2FLI-EMOJI%3E%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%20If%20xRgS%20Is%20Nothing%20Then%20Exit%20Sub%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%20Set%20xRgD%20%3D%20Application.InputBox(%22Please%20select%20a%20destination%20cell%3A%22%2C%20%22KuTools%20For%20Excel%22%2C%20%2C%20%2C%20%2C%20%2C%20%2C%20%3CLI-EMOJI%20id%3D%22lia_smiling-face-with-sunglasses%22%20title%3D%22%3Asmiling_face_with_sunglasses%3A%22%3E%3C%2FLI-EMOJI%3E%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%20If%20xRgD%20Is%20Nothing%20Then%20Exit%20Sub%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%20xCol%20%3D%20xRgS.Rows.Count%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%20Set%20xRgS%20%3D%20xRgS(1)%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%20Application.CutCopyMode%20%3D%20False%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%20J%20%3D%200%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%20For%20I%20%3D%201%20To%20xCol%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20Set%20xCell%20%3D%20xRgS.Offset(I%20-%201%2C%200)%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20xVal%20%3D%20xCell.Value%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20If%20TypeName(xVal)%20%3D%20%22Date%22%20And%20(xVal%20%26lt%3B%26gt%3B%20%22%22)%20And%20(xVal%20%3D%20Date)%20Then%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20xCell.EntireRow.Copy%20xRgD.Offset(J%2C%200)%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20J%20%3D%20J%20%2B%201%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20End%20If%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%20Next%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%20Application.CutCopyMode%20%3D%20True%3CBR%20%2F%3EEnd%20Sub%3C%2FP%3E%3C%2FLINGO-BODY%3E%3CLINGO-LABS%20id%3D%22lingo-labs-1285810%22%20slang%3D%22en-US%22%3E%3CLINGO-LABEL%3EDeveloper%3C%2FLINGO-LABEL%3E%3CLINGO-LABEL%3EExcel%3C%2FLINGO-LABEL%3E%3C%2FLINGO-LABS%3E
Highlighted
Occasional Visitor

I have this code and it works great for what I need except I would like it to select the same copy column and same paste cell everytime. rather than me having to select it everytime. please help

Sub CopyRow()
'Updateby Extendoffice
    Dim xRgS As Range, xRgD As Range, xCell As Range
    Dim I As Long, xCol As Long, J As Long
    Dim xVal As Variant
    On Error Resume Next
    Set xRgS = Application.InputBox("Please select the date column:", "KuTools For Excel", Selection.Address, , , , ,
    If xRgS Is Nothing Then Exit Sub
    Set xRgD = Application.InputBox("Please select a destination cell:", "KuTools For Excel", , , , , ,
    If xRgD Is Nothing Then Exit Sub
    xCol = xRgS.Rows.Count
    Set xRgS = xRgS(1)
    Application.CutCopyMode = False
    J = 0
    For I = 1 To xCol
        Set xCell = xRgS.Offset(I - 1, 0)
        xVal = xCell.Value
        If TypeName(xVal) = "Date" And (xVal <> "") And (xVal = Date) Then
            xCell.EntireRow.Copy xRgD.Offset(J, 0)
            J = J + 1
        End If
    Next
    Application.CutCopyMode = True
End Sub

0 Replies