我需要
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
案例记录表洗涤板
最佳答案
复制转置列范围
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
关于excel - 复制和粘贴特殊值,即转置值以粘贴到另一个工作表的下一个可用行,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/71542527/