• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

need help to shorten my macro

Pilot5000

Pilot5000

New Member
I have sheet (sheet3) with columns of data , each week the number of columns with data change but all the time start in the same column "E" , looking for help with macro that will take the data from column "E" and copy it to another sheet(sheet 1) at the 2 rows after the last row with data in column "A", and keeping loop until last columns wit data in sheet 3 . now I have macro that I work with but from doing some reading I understand 1) that this is not the best way to do that 2) my problems as you can see from my macro is that when it copy it take 2 columns at the time and copy them

Code: 
Sub COPY_S1()
Application.ScreenUpdating = False
Range("E2:E" & Range("E" & Rows.Count).End(xlUp).Row).Select
Range(ActiveCell, ActiveCell.End(xlDown).Offset(0, 1)).Select
Selection.Copy Destination:=Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(3)

Range("G2:G" & Range("G" & Rows.Count).End(xlUp).Row).Select
Range(ActiveCell, ActiveCell.End(xlDown).Offset(0, 1)).Select
Selection.Copy Destination:=Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(3)
Range("I2:I" & Range("I" & Rows.Count).End(xlUp).Row).Select
Range(ActiveCell, ActiveCell.End(xlDown).Offset(0, 1)).Select
Selection.Copy Destination:=Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(3)
Range("K2:K" & Range("K" & Rows.Count).End(xlUp).Row).Select
Range(ActiveCell, ActiveCell.End(xlDown).Offset(0, 1)).Select
Selection.Copy Destination:=Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(3)
Range("M2:M" & Range("M" & Rows.Count).End(xlUp).Row).Select
Range(ActiveCell, ActiveCell.End(xlDown).Offset(0, 1)).Select
Selection.Copy Destination:=Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(3)
Range("O2:O" & Range("O" & Rows.Count).End(xlUp).Row).Select
Range(ActiveCell, ActiveCell.End(xlDown).Offset(0, 1)).Select
Selection.Copy Destination:=Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(3)
Range("S2:S" & Range("S" & Rows.Count).End(xlUp).Row).Select
Range(ActiveCell, ActiveCell.End(xlDown).Offset(0, 1)).Select
Selection.Copy Destination:=Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(3)
Range("U2:U" & Range("U" & Rows.Count).End(xlUp).Row).Select
Range(ActiveCell, ActiveCell.End(xlDown).Offset(0, 1)).Select
Selection.Copy Destination:=Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(3)
Range("W2:W" & Range("W" & Rows.Count).End(xlUp).Row).Select
Range(ActiveCell, ActiveCell.End(xlDown).Offset(0, 1)).Select
Selection.Copy Destination:=Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(3)
Application.ScreenUpdating = True
End Sub
Thank you or any help in advance


M.S
 
M.S

I think this will do it

Code: 
Sub COPY_S1()
Dim i As Integer

Application.ScreenUpdating = False

For i = 5 To 23 Step 2
  If i <> 17 Then  Range(Cells(2, i), Cells(2, i).End(xlDown).Offset(, 1)).Copy Destination:=Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(3)
Next i
Aplication.ScreenUpdating = True
End Sub
 
Hi Hui

thank you for the effort and time to try and helping me
I tried your code and first time I run it I get message error "Next without For"
then I added "end if" , but I got another error message "Object required (Error 424)"
can you help me with that the code is not running
thanks again
 
Last edited by a moderator:
There was a spelling mistake in the last Application
The code works fine with value in the data area
Where are you placing the code?
I have assumed it is in the Sheet2 code module

Code: 
Sub COPY_S1()
Dim i As Integer

Application.ScreenUpdating = False

For i = 5 To 23 Step 2
  If i <> 17 Then Range(Cells(2, i), Cells(2, i).End(xlDown).Offset(, 1)).Copy Destination:=Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(3)
Next
Application.ScreenUpdating = True
End Sub

If it is elsewhere maybe add a single line to select the data sheet up front

Code: 
Sub COPY_S1()
Dim i As Integer

Application.ScreenUpdating = False
Worksheets("Sheet2").Select

For i = 5 To 23 Step 2
  If i <> 17 Then Range(Cells(2, i), Cells(2, i).End(xlDown).Offset(, 1)).Copy Destination:=Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(3)
Next
Application.ScreenUpdating = True
End Sub

If you could paste the file it would make debugging so much easier
 
it's sheet3 and I will try the new instruction and let you know , I got this message on my phone and I am not in front of the my computer , I will do that later promise to let you know , that's the minimum I can do to thank you for everything you doing to help me


Hui said:
There was a spelling mistake in the last Application
The code works fine with value in the data area
Where are you placing the code?
I have assumed it is in the Sheet2 code module

Code: 
Sub COPY_S1()
Dim i As Integer

Application.ScreenUpdating = False

For i = 5 To 23 Step 2
  If i <> 17 Then Range(Cells(2, i), Cells(2, i).End(xlDown).Offset(, 1)).Copy Destination:=Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(3)
Next
Application.ScreenUpdating = True
End Sub

If it is elsewhere maybe add a single line to select the data sheet up front

Code: 
Sub COPY_S1()
Dim i As Integer

Application.ScreenUpdating = False
Worksheets("Sheet2").Select

For i = 5 To 23 Step 2
  If i <> 17 Then Range(Cells(2, i), Cells(2, i).End(xlDown).Offset(, 1)).Copy Destination:=Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(3)
Next
Application.ScreenUpdating = True
End Sub

If you could paste the file it would make debugging so much easier
Click to expand...
 
This is a slight bit shorter as well

Code: 
Sub COPY_S1()
Dim i As Integer

Application.ScreenUpdating = False
Worksheets("Sheet2").Select

For i = 5 To 23 Step 2
  If i <> 17 Then Range(Cells(2, i), Cells(2, i + 1).End(xlDown)).Copy Destination:=Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(3)
Next
Application.ScreenUpdating = True
End Sub
 
thank you very very much






Hui said:
This is a slight bit shorter as well

Code: 
Sub COPY_S1()
Dim i As Integer

Application.ScreenUpdating = False
Worksheets("Sheet2").Select

For i = 5 To 23 Step 2
  If i <> 17 Then Range(Cells(2, i), Cells(2, i + 1).End(xlDown)).Copy Destination:=Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(3)
Next
Application.ScreenUpdating = True
End Sub
Click to expand...
 
You must log in or register to reply here.
Back
Top