2
\$\begingroup\$

Following takes a range & copies, pastes, transposes & links. There doesn't seem a way in vba to do this in 1 go that I've been able to find.

Questions are;

  1. Is there a more efficient or safer way to do this. Keeping in mind;
    -needing to do this for large ranges ie. over 100K cells.
    -source & destination are in different worksheets or workbooks. So not the same worksheet.
  2. What issues if any may exist & how to safeguard.

Thank you


Sub Foo()

    'Example1
    Call CopyPaste(Sheet1.Range("C10:D20"), Sheet2.Range("C1"))
     
    'Example2
    Dim wbNew As Workbook
    Set wbNew = Workbooks.Add
    Call CopyPaste(ThisWorkbook.Sheets(1).Range("C10:D20"), wbNew.Sheets(1).Range("C1"))

End Sub

Sub CopyPaste(rngSrc As Range, rngDest As Range)
    
    Application.ScreenUpdating = False
    ActiveWorkbook.Sheets.Add.Name = "_wsDummy_Temp_"
    Dim wsDummy As Worksheet
    Set wsDummy = ActiveWorkbook.Sheets("_wsDummy_Temp_")   

    rngSrc.Copy
    wsDummy.Activate
    wsDummy.Range("A1").Select
    ActiveSheet.Paste Link:=True
    
    Dim vTransposed As Variant
    Dim rngSrcSrcRng As Range
    Dim vSrcSrc As Variant
    
    Dim rngDummy As Range
    Set rngDummy = wsDummy.Range("A1")
    Set rngDummy = rngDummy.Resize(rngSrc.Rows.Count, rngSrc.Columns.Count)
    rngDummy.Formula = Application.ConvertFormula(rngDummy.Formula, xlA1, xlA1, 1)
    
    Set rngSrcSrcRng = rngDummy
    vSrcSrc = rngSrcSrcRng.Formula
    vTransposed = Application.Transpose(vSrcSrc)
    
    Set rngDest = rngDest.Resize(rngDummy.Columns.Count, rngDummy.Rows.Count)
    rngDest.Formula = vTransposed

    rngDummy.ClearContents
    Application.DisplayAlerts = False
    wsDummy.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub

EDIT:

With the answer provided @TinMan I decided to fill over a 1M cells in a worksheet with numbers & do some benchmarking.

Original OP function: 33 to 39 seconds.
Refactored CopyPaste function: 20 to 26 seconds.
Alternate Approach TransposeLink function: 11 to 13 seconds.

It appears the last one is the fastest in the tests I did but also removes the need to use another temporary worksheet, removes need to use select or the clipboard.

\$\endgroup\$
  • \$\begingroup\$ Do you have calculations set to manual? \$\endgroup\$ – TinMan Jul 4 at 23:44
  • \$\begingroup\$ No I haven't & I hadn't even thought of that. At the moment this is quite quick & haven't noticed any slowdown, but as the range grows I guess that may be an issue. \$\endgroup\$ – tnuba Jul 5 at 20:25
3
\$\begingroup\$

Review

Private Sub CopyPaste(rngSrc As Range, rngDest As Range)

Prefixing variables with their type is a bit dated. Of course there are times when it is invaluable such as working with forms where their is a designer and a code module. Using simple meaningful names will make you code easier to read.

Private Sub CopyPaste(Source As Range, Destination As Range)

There is no need to name temporary objects.

ActiveWorkbook.Sheets.Add.Name = "_wsDummy_Temp_"
Dim wsDummy As Worksheet
Set wsDummy = ActiveWorkbook.Sheets("_wsDummy_Temp_")

It better to set your variables directly whenever possible.

Set wsDummy = ActiveWorkbook.Sheets.Add

Since the worksheet is just temporary and the code is short, I would use a With block and eliminate the wsDummy variable altogether.

With ActiveWorkbook.Sheets.Add
    .Paste Link:=True
    <more code>
End With

Worksheets are activated with Range("A1") selected whenever they are added. So eliminate these lines:

wsDummy.Activate
wsDummy.Range("A1").Select

Ay-ay-ay rngSrcSrcRng!! This variable is just an alias for rngDummy`. Pick a name and stick with it. I take this concept to the extreme. You will see the same names throughout all my code projects. IMO, consistently using simple names like data ( array ), results ( array ), result (scalar value), r (row index) , c (column index), n (generic index), text ( simple string ), contents ( simple string usually file contents), source (source object such as a range) , destination (destination object such as a range), cell, target don't just make it easier to read and modify your code but it also makes it far quicker to write the code, in the first place.

vTransposed isn't needed either. It would be better to reuse vSrcSrc then to keep both variables in memory.

Clearing the contents of a temporary worksheet. I'm guessing this is a remnant of code from your earlier attempts.

rngDummy.ClearContents

After your macros complete Application.DisplayAlerts and Application.ScreenUpdating are automatically reset. So these lines can be removed:

Application.DisplayAlerts = True
Application.ScreenUpdating = True

It is best to set Application.Calculation = xlCalculationManual when changing values or formulas on a worksheet.

Refactored Code

Private Sub CopyPaste(Source As Range, Destination As Range)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Dim calculationMode As XlCalculation
    calculationMode = Application.Calculation
    
    Dim results As Variant

    Source.Copy
    With Worksheets.Add
        .Paste Link:=True
         With .Range("A1").CurrentRegion
            results = Application.ConvertFormula(.Formula, xlA1, xlA1, 1)
            Destination.Resize(.Columns.Count, .Rows.Count) = Application.Transpose(results)
        End With
        .Delete
    End With
    
    Application.Calculation = calculationMode
End Sub

Alternate Approach

A more efficient method create the formula array using Range.Address(RowAbsolute:=True, ColumnAbsolute:=True, External:=True). This will eliminate the need for a temporary worksheet and avoid the copy and pasting.

 Private Sub TransposeLink(Source As Range, Destination As Range)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Dim calculationMode As XlCalculation
    calculationMode = Application.Calculation
    
    Dim results As Variant
    With Source
        ReDim results(1 To .Columns.Count, 1 To .Rows.Count)
        
        Dim r As Long, c As Long
        
        For r = 1 To .Rows.Count
            For c = 1 To .Columns.Count
                    results(c, r) = "=" & .Cells(r, c).Address(RowAbsolute:=True, ColumnAbsolute:=True, External:=True)
            Next
        Next
        
        Destination.Resize(.Columns.Count, .Rows.Count).Formula = results
    End With
    
    Application.Calculation = calculationMode
End Sub
| improve this answer | |
\$\endgroup\$
  • \$\begingroup\$ After I posted I noticed some issues, thanks. I'll update my OP soon with some benchmarking. \$\endgroup\$ – tnuba Jul 6 at 21:11
  • \$\begingroup\$ @tnuba By the way, great concept! Excel should implement it. \$\endgroup\$ – TinMan Jul 6 at 21:17
  • \$\begingroup\$ Yes I don't know why MS don't, it's a much sought after functionality. I find myself needing to do this way too much hence my post. Knew there would be a better way & knew using select or activate isn't always good idea, just didn't know how as haven't been using vba that long. So thanks. \$\endgroup\$ – tnuba Jul 6 at 21:33
  • \$\begingroup\$ I noticed that your alternate method didn't handle ranges with multiple areas well, so I added another answer building on it. Cheers \$\endgroup\$ – Taylor Scott Jul 8 at 4:09
2
\$\begingroup\$

A modification if Tinman's Alternate Approach

Because .Rows.Count and .Columns.Count do not encapsulate the entirety of ranges which have more than one area (that is, where .Areas.Count >1) TransposeLink as defined above needs some modifcation to handle these cases.

Namely, we will have to define an helper function that gets the footprint of all of the areas of source, then iterate across the rows and columns of that footprint rather than of source directly. In doing so, we also must check if the footprint Intersects with source, and only iff that is the case, transfer over the formula.

Application of these changes renders code somewhere along the lines of the below.

Option Compare Binary
Option Explicit
Option Base 1


Public Sub TransposeLink(ByRef src As Range, ByRef dest As Range)
    Dim ASU As Boolean, _
        ADA As Boolean, _
        ACM As Excel.XlCalculation, _
        row As Long, _
        col As Long
    
    With Application
        Let ASU = .ScreenUpdating: Let .ScreenUpdating = False
        Let ADA = .DisplayAlerts:  Let .DisplayAlerts = False
        Let ACM = .Calculation:    Let .Calculation = Excel.XlCalculation.xlCalculationManual
    End With
    
    With footprint(src)
        ReDim res(1 To .Columns.Count, 1 To .Rows.Count)            '' dim in as variant()
        Let res = dest.Resize(.Columns.Count, .Rows.Count).Formula  '' to not overwrite data
        For row = 1 To .Rows.Count
            For col = 1 To .Columns.Count
                If Not Intersect(.Cells(row, col), src) Is Nothing Then _
                    Let res(col, row) = "=" & .Cells(row, col).Address(RowAbsolute:=True, ColumnAbsolute:=True, External:=True)
        Next col, row
        Let dest.Resize(.Columns.Count, .Rows.Count).Formula = res
    End With
    
    With Application
        Let .ScreenUpdating = ASU
        Let .DisplayAlerts = ADA
        Let .Calculation = ACM
    End With
End Sub


Public Function footprint(ByRef rng As Range) As Range

    Dim numAreas           As Long, _
        rMin As Long, rMax As Long, _
        cMin As Long, cMax As Long, _
        iter As Long
    
    Let numAreas = rng.Areas.Count
    If numAreas = 1 Then Set footprint = rng: Exit Function
    
    For iter = 1 To numAreas
        With rng.Areas(iter)
            If iter = 1 Then
                Let rMin = .Item(1).row
                Let cMin = .Item(1).Column
                Let rMax = .Item(.Count).row
                Let cMax = .Item(.Count).Column
            Else
                If .Item(1).row < rMin Then Let rMin = .Item(1).row
                If .Item(1).Column < cMin Then Let cMin = .Item(1).Column
                If .Item(.Count).row > rMax Then Let rMax = .Item(.Count).row
                If .Item(.Count).Column > cMax Then Let cMax = .Item(.Count).Column
            End If
        End With
    Next iter
    
    With rng.Worksheet
        Set footprint = .Range(.Cells(rMin, cMin), .Cells(rMax, cMax))
    End With
End Function

Note the addition of the Option Explicit module option at the top of this code segment - enabling this helps you to keep track of your what variables you are using by forcing you to dim them in before using them.

Testing

A simple test which illustrates the impact is

Sub trans_test()
    [A1:U9] = "=Right(Address(Row(),Column(),4))&Left(Address(Row(),Column(),4))"
                                            ' yellow - source
    TransposeLink [A1,C3,E5], [I3]          ' green  - new
    OLD_TransposeLink [A1,C3,E5], [Q5]      ' red    - old
    
    Cells.Style = "normal"
    [A1,C3,E5].offset(0, 0).Style = "neutral"
    [A1,C3,E5].offset([I3].row - 1, [I3].Column - 1).Style = "good"
    [A1,C3,E5].offset([Q5].row - 1, [Q5].Column - 1).Style = "bad"
    
End Sub

where OLD_TransposeLink is the original version of the subroutine and which generates the worksheet shown below. In this example, a background set of formulas is generated, and then A1, C3, and E5 (highlighted in yellow) are selected as the data source. The green highlighted region represents the pasting operation completed by the changed script and the red highlighted region represents that of the original script. Note that in the original output, 3C and 5E are not properly copied over from the source.

test-output

Note: top left cell is cell A1

| improve this answer | |
\$\endgroup\$
  • 2
    \$\begingroup\$ Very cleaver. I never would have thought to handle multiple areas. \$\endgroup\$ – TinMan Jul 8 at 6:11

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.