Shift columns each click of the button

[EMoe]

Hello Programmers,

This code takes data from selected cells on sheet 1, then tranfers them
to a column starting with C on sheet2. How do I add to this code, so
that the next time I hit the macro button, the data shifts over to
column D, then E, etc...


'subroutine to transfer data to another sheet

Sub TransferData()
Application.ScreenUpdating = False
Sheets("WorksheetCopy").Range("B1:B2").Copy
Sheets("Worksheet Info").Range("D3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

Sheets("WorksheetCopy").Range("D3134").Copy
Sheets("Worksheet Info").Range("D6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

Sheets("WorksheetCopy").Range("D3639").Copy
Sheets("Worksheet Info").Range("D10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

Range("D23").Select
Application.ScreenUpdating = True
End Sub
Thanks,
EMoe

 

[Tom Ogilvy]

Your code puts the results in column D rather than Column C, nonetheless,
this is written to begin in column C and progress to the right. It assumes
that the 3rd row will contain a value after that column has been pasted to.

Sub TransferData()
Dim v1 As Variant, v2 As Variant
Dim sh1 As Worksheet, sh2 As Worksheet
Dim rng As Range
v1 = Array("B1:B2", "D3134", "D3639")
v2 = Array(3, 6, 10)
Set sh1 = Sheets("WorksheetCopy")
Set sh2 = Sheets("Worksheet Info")

Set rng = sh2.Cells(3, "IV").End(xlToLeft)(1, 2)
If rng.Column < 3 Then ' change to 4 if you want Column D as the start
Set rng = sh2.Range("C3")
End If
For i = LBound(v1) To UBound(v1)
sh1.Range(v1(i)).Copy
sh2.Cells(v2(i), rng.Column).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, _
Skipblanks:=False, Transpose:=False
Next
sh2.Activate
Range("D23").Select
Application.ScreenUpdating = True
End Sub

 

[anilsolipuram]

backup your orignal workbook before executing this macro



Sub TransferData()

Application.ScreenUpdating = False
Dim r As Range
Dim offset, temp, temp1 As Variant
Set r = Sheets("Worksheet Info").UsedRange
t = Split(r.Address, ":")
If UBound(t) > 0 Then
temp = Range(t(1)).Column
temp1 = temp + 1 - Range("d2").Column
If (temp1 <= 0) Then
off_set = 0
Else
off_set = temp1
End If
Else
off_set = 0
End If

Sheets("WorksheetCopy").Range("B1:B2").Copy

Sheets("Worksheet Info").Select
Sheets("Worksheet Info").Range("D3").offset(0, off_set).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
SkipBlanks _
:=False, Transpose:=False
Sheets("WorksheetCopy").Select

Sheets("WorksheetCopy").Range("D3134").Copy
Sheets("Worksheet Info").Select
Sheets("Worksheet Info").Range("d6").offset(0, off_set).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
SkipBlanks _
:=False, Transpose:=False
Sheets("WorksheetCopy").Select
Sheets("WorksheetCopy").Range("D3639").Copy
Sheets("Worksheet Info").Select
Sheets("Worksheet Info").Range("d10").offset(0, off_set).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
SkipBlanks _
:=False, Transpose:=False
Sheets("WorksheetCopy").Select
Range("D23").Select
Application.ScreenUpdating = True
End Su

 

[EMoe]

Hi,

This formula works pretty good. However, if I format the cells (i.e.
bold, or currency) the code skips these columns then go to the next
one. I tried to delete
the formats, and for some reason it still skips the cells as if
something is still in them. Now its starting out at column I, and not
D.

???,
EMoe

 

[EMoe]

Sorry for the double post. Tom you must have been typing was I was, and
submitted before I did. The code I'm referring to is that of
Anilsolipuram, so there is no confusion. I'll try yours Tom.

Thanks,
EMoe

 

[EMoe]

Thanks alot, for both of your help.

Tom, works like a charm, even through the format of the cells.

Regards,
EMo

 

[EMoe]

On the line: v1 = Array("B1:B2", "D3134", "D3639", "D4142"), I
added the "D4142", and got this error:

sh2.Cells(v2(i), rng.Column).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, _
Skipblanks:=False, Transpose:=False

How do I add more cells. In the first thread that I posted, I only used
a few cells as an example. I need to add D4142, I31:32, H33, & I36:38
respectively.

Thanks,
EMoe

 

[EMoe]

Disregard, Disregard!

I see now, that I changed the v2 Array value (or added on to them s
that it corresponds to the repective cell where the data is to b
pasted(if that makes since).

Anyway, I got it to work.

Thanks a bunck,
EMo

 

[Guest]

You could capture the column of the usedrange (thus far) on your destination
worksheet (assuming your destination worksheet does not contain multiple
tables or other extraneous data that is in a column to the right of column C).


with Sheets("Worksheet Info").usedrange
NewCol = .columns(.columns.count).column + 1
end with

Then when you select the range in "Worksheet Info" to paste the data you'd
use Cells instead of Range object

Sheets("Worksheet Info").Cells(3,NewCol).Select

is equivalent to selecting range "D3."


If you do have other tables/data causing the usedrange column to extend past
C, look at using Areas or CurrentRegion to set the new column to paste data
into.