Copy Non-Empty Range to Another Worksheet
- It should be a
Sub
procedure because it doesn't return a value. A Function
does.
- Use
Option Explicit
.
- Pasting values is faster using 'copying by assignment' e.g.
drg.Value = srg.Value
.
- Avoid using
Select
and Active
.
- Since you're using strings for the arguments you should use error handling. See it in action when using an invalid address, e.g. "A".
- The first argument should be a one-row (one-cell) address, while the second should be a one-cell address.
- The code may be out of your league, but that shouldn't stop you from using it successfully. The first procedure illustrates how you can utilize it easily.
Option Explicit
Sub CopyRangeAndPasteAtTEST()
CopyRangeAndPasteAt "L2", "AE2"
'CopyRangeAndPasteAt "L2", "AE2", True ' will transpose
'CopyRangeAndPasteAt "L2:O2", "AE2" ' more columns (more rows not included)
'CopyRangeAndPasteAt "L2", "AE2", True ' will transpose (more columns)
End Sub
Sub CopyRangeAndPasteAt( _
ByVal SourceAddress As String, _
ByVal DestinationAddress As String, _
Optional ByVal doTranspose As Boolean = False)
Const ProcName As String = "CopyRangeAndPasteAt"
On Error GoTo clearError
Dim sws As Worksheet: Set sws = Sheet2
Dim dws As Worksheet: Set dws = Sheet6
Dim srg As Range
Dim rCount As Long, cCount As Long
Dim wasCopied As Boolean
With sws.Range(SourceAddress).Rows(1)
cCount = .Columns.Count
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If lCell Is Nothing Then GoTo ProcExit
rCount = lCell.Row - .Row + 1
Set srg = .Resize(rCount)
End With
Dim drg As Range
With dws.Range(DestinationAddress).Cells(1)
If doTranspose Then
Dim sData As Variant
If cCount + rCount = 2 Then
ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
Else
sData = srg.Value
End If
Dim dData As Variant: ReDim dData(1 To cCount, 1 To rCount)
Dim r As Long, c As Long
For r = 1 To rCount
For c = 1 To cCount
dData(c, r) = sData(r, c)
Next c
Next r
Set drg = .Resize(cCount, rCount)
drg.Value = dData
' Clear contents to the right.
'.Resize(cCount, .Worksheet.Columns.Count - .Column - rCount + 1) _
.Offset(, rCount).ClearContents
Else
Set drg = .Resize(rCount, cCount)
drg.Value = srg.Value
' Clear contents to the bottom.
'.Resize(.Worksheet.Rows.Count - .Row - rCount + 1, cCount) _
.Offset(rCount).ClearContents
End If
End With
wasCopied = True
ProcExit:
If wasCopied Then
MsgBox "Data successfully copied.", vbInformation, "Copy Range"
Else
MsgBox "Data NOT copied.", vbCritical, "Copy Range"
End If
Exit Sub
clearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Sub