PDA

View Full Version : [SOLVED] VBA loop to do multiple cut, transpose pastes within a loop, then repeat.



RINCONPAUL
06-11-2016, 05:15 PM
I've recorded a macro as below. I need some code to enable the steps to be repeated, however, after cycle is complete, the copy Range A2:E2 moves down a row to A3:E3, similarly with Range F2:J2. The paste Ranges N10 and O10 remain static as well as copy Range M10:O14. The next paste Range R2 moves down to next blank Range R7. This repeats until a blank row is met in the copy range of rows in col A. In the attachment you can see the one off recorded macro.
Thanks, as always for your time.



Sub CutpasteLoop()
'
' CutpasteLoop Macro
'Range("A2:E2").Select
Selection.Copy
Range("N10").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("F2:J2").Select
Application.CutCopyMode = False
Selection.Copy
Range("O10").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("M10:O14").Select
Application.CutCopyMode = False
Selection.Copy
Range("R2").Select
ActiveSheet.Paste
End Sub

Trebor76
06-11-2016, 06:01 PM
Hi RINCONPAUL,

Try this:


Option ExplicitSub Macro1()


Dim lngLastRow As Long
Dim lngMyRow As Long
Dim lngLinkRow As Long
Dim i As Integer

Application.ScreenUpdating = False

lngLastRow = Range("R:T").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lngLinkRow = 2

For lngMyRow = 2 To lngLastRow
Range("A" & lngLinkRow).Offset(0, i) = Range("S" & lngMyRow)
Range("F" & lngLinkRow).Offset(0, i) = Range("T" & lngMyRow)
If i = 4 Then
lngLinkRow = lngLinkRow + 1
i = 0
Else
i = i + 1
End If
Next lngMyRow

Application.ScreenUpdating = True


End Sub

Regards,

Robert

mdmackillop
06-11-2016, 06:08 PM
Option Explicit
Sub CutpasteLoop()
Dim Rw As Long, i As Long, Tgt As Range
Rw = 2
Set Tgt = Range("N10")
Do
For i = 0 To 1
Cells(Rw, 1).Offset(, 5 * i).Resize(, 5).Copy
Tgt.Offset(, i).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Next
Tgt.Offset(, -1).Resize(5, 3).Copy Cells(Rows.Count, "R").End(xlUp)(2)
Rw = Rw + 1
If Cells(Rw, 1) = "" Then Exit Sub
Loop
End Sub

RINCONPAUL
06-11-2016, 07:03 PM
mdmackillop, your code worked great on the sample sheet, not so well yours Robert, but cheers for your input :)
As always the ramping up from sample to real world has caused issues. In the sample, the transposed pasted cell contents were "processed" by a very simple formula inserted in cells M10:M14. That calculation is almost instant, and then the results are pasted to R2 down. In the real world those "M" cells contain a count formula of a large array of calculations that take place!

mdmackillop, I can see your code running and churning through it's loops, but the results are not pasted (only one set)? The reason being I suspect is the processing of the initial transposed pasted cells takes a split second, and then the next paste should occur. How can you compensate for that lag? I am happy to upload a real worksheet if you wish?
Cheers

RINCONPAUL
06-11-2016, 07:19 PM
Apologies Maestro. I had stuffed up something in the conversion recode. Your proficiency as Grand Master is without equal, as your code works like a V10 motor at full throttle.:jsmile:

Trebor76
06-11-2016, 07:49 PM
not so well yours Robert, but cheers for your input

That's odd - worked for me :confused:

In any case I'm glad mdmackillop's nifty solution worked for you.

Regards,

Robert

RINCONPAUL
06-11-2016, 08:12 PM
Yes, on reflection, I probably stuffed something up implementing your worthy code. mdmackillop just does it 'smoke and mirrors' doesn't he? There's barely a cell reference in those few lines, it just 'happens". LOL
Great to see another Aussie flag waving on the forum.

Trebor76
06-11-2016, 09:40 PM
mdmackillop just does it 'smoke and mirrors' doesn't he?

Yes, he sure does.


Great to see another Aussie flag waving on the forum.

Three cheers (or should I say three Oi's) for that :)

mdmackillop
06-12-2016, 03:53 AM
Thanks for the kind comments.
Re your methodology, the intermediate step seems to serve no purpose. You can place the data directly and then either add the formulae via code or copy and paste the formulae only (as below). To speed things up, for your real life situation, I've added the Enables routine.


Option Explicit
Sub CutpasteLoop()
Dim Rw As Long, i As Long, Tgt As Range
Dim Fmla As Range, s As Range
On Error GoTo Exits
Enables False
Set s = Selection
Rw = 2
Set Fmla = Range("M10").Resize(5)
Do
Set Tgt = Cells(Rows.Count, "S").End(xlUp)(2)
For i = 0 To 1
Cells(Rw, 1).Offset(, 5 * i).Resize(, 5).Copy
Tgt.Offset(, i).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Next
Fmla.Copy Tgt.Offset(, -1)
Rw = Rw + 1
If Cells(Rw, 1) = "" Then Exit Do
Loop
Exits:
Application.Goto s
Enables True
End Sub


Sub Enables(x As Boolean)
With Application
.ScreenUpdating = x
.EnableEvents = x
If x Then
.Calculation = xlCalculationAutomatic
Else
.Calculation = xlCalculationManual
End If
End With
End Sub