Copy adjacent cells and paste in non adjacent columns

[jolivanes]

Bob (xld) kindly supplied me with code to make a summary sheet where
two cells are copied from a multiple amount of sheets and pasted in
the summary sheet. These cells are adjacent. All this works great.
See http://www.vbaexpress.com/forum/showthread.php?t=26090
After all is done, I cut the cells in Column B and paste them in Column D.
The code I got from Bob is as follows:

For shNum = 4 To Worksheets.Count 
 
   Set sh = Worksheets(shNum) 
   If sh.Name <> destSH.Name Then 
       sh.Range("B3:C3").Copy 
       With destSH.Cells(rw, 1) 
           .PasteSpecial Paste:=xlPasteValues 
       End With 
 
       rw = rw + 1 
   End If 
Next shNum

I added the following below it to move column B values to column D:

Range("B10:B" & Cells(Rows.Count, "B").End(xlUp).Row).Cut Destination:=Range("D10")

Would there be an efficient way, without losing speed, to incorporate
that in the macro from Bob?

Thanks and Regards
John

[MikeBlackman]

Hi,

Do you need the formula in Col B or just the values? Maybe;

Dim lRow As Long
 
lRow = Range("B" & Rows.count).End(xlUp).Row
 
With Range("B10:B" & lRow)
    Range("D10:D" & lRow) = .Value
    .Value = ""
End With

[jolivanes]

Good Morning (afternoon) Mike.
Sorry for the confusion.
What I meant is when Bob's solution takes the info from
one sheet and copies it to the summary sheet, instead of pasting it in adjacent cells in the summary sheet, paste it in offsetting columns.
I would like, if it is possible, have the string copied from column B pasted
in column A in the summary sheet and the values copied from column C
pasted in column D.
For instance, the first time it copies the two adjacent cells, it pastes them in column A so the string will be in column A and the value will be in column B. I would like the value to be in column D.
I hope I expressed myself clearly.
Thank you for helping Mike

Regards
John

[MikeBlackman]

Hi,

Maybe this instead?

For i = 4 To Worksheets.count
    With Sheets(i)
        If .Name <> destSH.Name Then ' destSH.Name has not yet been defined???
            destSH.Cells(i - 3, 1).Resize(1, 2) = .Range("B3:C3")
            .Range("D3") = .Range("C3")
        End If
    End With
Next i

[jolivanes]

Hi Mike
I have to work with it a little later when I have some more time. I just quickly tried it and it did not copy anything at all. More then likely that I did not insert it proper in the whole macro.
Will let you know Mike.
Thanks and regards
John

[jolivanes]

Hi Mike
I tried changing some of the code you supplied but nothing I do makes it work.
Thanks for the help Mike.
Regards.
John

[mdmackillop]

Something like
[vba]
Option Explicit
Sub SwapColumns()
Dim destSH As Worksheet, sh As Worksheet
Dim Rw As Long, shNum As Long
Rw = 2
Set destSH = ActiveSheet
For shNum = 4 To Worksheets.Count
Set sh = Worksheets(shNum)
With destSH
.Cells(Rw, 2).Value = sh.Range("C3").Value
.Cells(Rw, 3).Value = sh.Range("B3").Value
End With
Rw = Rw + 1
Next shNum
End Sub

[/vba]

[jolivanes]

mdmackillop.
Yes, that's it. Thanks a million.
One thing baffles me though. I tried your code on a workbook with 35 sheets and it will put the first amount from cell D10 also in cell D45 but
not the relevant string in cell A45. What I am trying to say is that I get
one extra entry in column D at the end that should not be there.

The code is now as follows:

Sub SwapColumns()
    Dim destSH As Worksheet, sh As Worksheet
    Dim Rw As Long, shNum As Long
    Application.ScreenUpdating = False

    Sheets("Daily").Copy After:=Sheets(Sheets.Count)
        With ActiveSheet
            .Name = "Summary"
            .Shapes("SaveDailyButton").Delete
            .Range("A10:D" & Cells(Rows.Count, "D").End(xlUp).Row).ClearContents
        End With

    Rw = 10
    Set destSH = Worksheets("Summary")  'ActiveSheet
    For shNum = 4 To Worksheets.Count
        Set sh = Worksheets(shNum)
        With destSH
            .Cells(Rw, 1).Value = sh.Range("C10").Value
            .Cells(Rw, 4).Value = sh.Range("D10").Value
        End With
        Rw = Rw + 1
    Next shNum

    With Sheets("Summary").Range("A10:D" & Cells(Rows.Count, "D").End(xlUp).Row).Font
        .Name = "Verdana"
        .Size = 9
        .Bold = False
        .Italic = False
    End With

With Sheets("Summary").Range("D10:D" & Cells(Rows.Count, "D").End(xlUp).Row)
    .NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
End With
Application.ScreenUpdating = True

End Sub

I can't find why it would be doing that.

[mdmackillop]

Because you are adding Summary as the last sheet
Try
[VBA]
For shNum = 4 To Worksheets.Count - 1

[/VBA]

[jolivanes]

mdmackillop.

Yes, absolutely right.

Thank you so much again.

A Happy Easter to you and yours.

Regards.

John