Copy & paste special that is transposing values to paste on the next available row of another sheet

user_18516109 0
Viewed 67

I need to

  • copy the data from Column M in my "Scrubber" sheet
  • post to my "Case Log" sheet on the next open row (in this case it would be the gold row 3, but need this to go to the next row each time)
  • clear my "Scrubber" sheet data (A:D)
Sub CCRS()
    Range("M2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("Case Log").Select
    Range("F4").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=True
    Sheets("Daily Scrubber").Select
    ActiveWindow.SmallScroll Down:=-63
    Range("D2").Select
    Range(Selection, Selection.End(xlToLeft)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.ClearContents
End Sub

Case Log Sheet
enter image description here

Scrubber Sheet
enter image description here

vba excel
1 Answers

Copy-Transpose Column Range

Option Explicit

Sub CCRS()
    
    ' Source
    Const sName As String = "Daily Scrubber"
    Const sCopyFirstCellAddress As String = "M2" ' column
    Const sClearFirstCellAddress As String = "A2"
    Const sClearColumnsCount As Long = 4
    ' Destination
    Const dName As String = "Case Log"
    Const dFirstCellAddress As String = "F2" ' row
    ' Both
    Const DataSize As Long = 7
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sCopyData As Variant
    Dim rng As Range
    
    ' Source
    With wb.Worksheets(sName)
        sCopyData = .Range(sCopyFirstCellAddress).Resize(DataSize).Value ' data
        Set rng = .Range(sClearFirstCellAddress) ' first cell
        With rng.CurrentRegion ' clear data (without headers)
            rng.Resize(.Row + .Rows.Count - rng.Row, .Column + .Columns.Count _
                - rng.Column).Resize(, sClearColumnsCount).ClearContents
        End With
    End With
    
    ' Destination
    With wb.Worksheets(dName)
        With .Range(dFirstCellAddress).Resize(, DataSize) ' first row
            Set rng = .Resize(.Worksheet.Rows.Count - .Row + 1) _
                .Find("*", , xlFormulas, , xlByRows, xlPrevious) ' last cell
            If rng Is Nothing Then
                Set rng = .Cells ' no data (no last cell); use first row
            Else
                Set rng = .Offset(rng.Row - .Row + 1) ' first empty row range
            End If
        End With
        rng.Value = Application.Transpose(sCopyData) ' write
    End With
    
    MsgBox "Column copy-transposed.", vbInformation
    
End Sub
user_98140690
Related