copy rows to table on another sheet

[wayneg]

I use this vba below to copy information from one sheet to another which works well, but i would like it to look down from row 52 until it meets a blank row. i know its something like

ActiveCell.Offset(1, 0).Select
Loop Until IsEmpty(ActiveCell) = True

but i am unsure how to adapt it

Private Sub CommandButton1_Click()

Application.ScreenUpdating = False

Dim copySheet As Worksheet

Dim pasteSheet As Worksheet



Set copySheet = Worksheets("Consultant Utilisation")

Set pasteSheet = Worksheets("Consultant Trends")



copySheet.Range("d52:y52").copy

pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

Application.CutCopyMode = False

Application.ScreenUpdating = True

End Sub

[:) Sixthsense :)]

Replace this line

pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

With

With pasteSheet
    .Range("A52", .Cells(52, "A").End(xlDown)).PasteSpecial xlPasteAll
End With

[wayneg]

will this still copy d to y columns as well ?

[:) Sixthsense :)]

Yes surely try it...

[wayneg]

i changed my code to say

Private Sub CommandButton1_Click()

Application.ScreenUpdating = False

Dim copySheet As Worksheet

Dim pasteSheet As Worksheet



Set copySheet = Worksheets("Consultant Utilisation")

Set pasteSheet = Worksheets("Consultant Trends")



copySheet.Range("aa3:ad3").copy



With pasteSheet

    .Range("Aa3", .Cells(3, "A").End(xlDown)).PasteSpecial xlPasteAll

End With



Application.CutCopyMode = False

Application.ScreenUpdating = True

End Sub

but it only pulled the first row off still, did i do something wrong ?

[:) Sixthsense :)]

Try this...

Private Sub CommandButton1_Click()
Dim copySheet As Worksheet, pasteSheet As Worksheet, lRw As Long

Set copySheet = Worksheets("Consultant Utilisation")
Set pasteSheet = Worksheets("Consultant Trends")

Application.ScreenUpdating = False

lRw = .Cells(3, "A").End(xlDown).Row
If lRw = Rows.Count Then lRw = 1

For i = 1 To lRw
    copySheet.Range("AA" & 2 + i & ":AD" & 2 + i).Copy
    pasteSheet.Range("AA" & 2 + i & ":AD" & 2 + i).Copy
Next i

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

[wayneg]

what i basically have is information in columns aa, ab, ac and ad on sheet "Consultant Utilisation"... i want each row copied on to the next available row on another sheet labelled "Consultant Trends" until it the row in "Consultant Utilisation" is blank.

if you need me to upload a sample i will, but i need to anonomise the data there due to the information being from a hospital.. data protection and all that..


i just edited this due to you putting in a new code above.. i will test that first.

[:) Sixthsense :)]

Oopss.. try this...

Private Sub CommandButton1_Click()
Dim copySheet As Worksheet, pasteSheet As Worksheet, lRw As Long, lNew As Long

Set copySheet = Worksheets("Consultant Utilisation")
Set pasteSheet = Worksheets("Consultant Trends")

Application.ScreenUpdating = False

lRw = copySheet.Cells(3, "A").End(xlDown).Row
If lRw = Rows.Count Then lRw = 1

For i = 1 To lRw
    lNew = pasteSheet.Cells(Rows.Count, "AA").End(xlUp).Row + 1
    copySheet.Range("AA" & 2 + i & ":AD" & 2 + i).Copy
    pasteSheet.Range("AA").PasteSpecial xlPasteAll
Next i

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

[wayneg]

this is my file. ignore the ref errors, its because i anonomised it.... the reason why i want this is because consultant utilisation page gets blanked each week, but i want it copied onto the consultant trends before i use it again

[wayneg]

i got a debug error when running your code sixthsense

[wayneg]

can anybody else help me as well please.

[wayneg]

bump bump bump

[wayneg]

i think i managed to do it myself.. this is what i got.. please have a look and tell me if there is an easier way

Private Sub CommandButton1_Click()



Application.ScreenUpdating = False



Dim copySheet As Worksheet

Dim pasteSheet As Worksheet

Dim xrow As Integer, xcol As Integer





xrow = 3

xcol = 27

xcolab = 28

xcolac = 29

xcolad = 30





Set copySheet = Worksheets("Consultant Utilisation")

Set pasteSheet = Worksheets("Consultant Trends")



Do Until Cells(xrow, xcol).Value = ""

                 Cells(xrow, xcol).Select

                 xrow = xrow + 1



copySheet.Cells(xrow, xcol).Copy

pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues



copySheet.Cells(xrow, xcolab).Copy

pasteSheet.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues



copySheet.Cells(xrow, xcolac).Copy

pasteSheet.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues



copySheet.Cells(xrow, xcolad).Copy

pasteSheet.Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues





Application.CutCopyMode = False

Application.ScreenUpdating = True

       

         Loop



         Cells(xrow - 1, xcol).Select





End Sub

[:) Sixthsense :)]

Try this…

Private Sub CommandButton1_Click()
Dim copySheet As Worksheet, pasteSheet As Worksheet, lBlank As Long
Dim lStRw As Long, iCl As Integer, lEndRw As Long, i As Long

lStRw = 3
iCl = 27

Set copySheet = Worksheets("Consultant Utilisation")
Set pasteSheet = Worksheets("Consultant Trends")

Application.ScreenUpdating = False

With copySheet
    lEndRw = .Cells(lStRw, iCl).End(xlDown).Row
    lBlank = pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
    
    .Range(.Cells(lStRw, iCl), .Cells(lEndRw, iCl)).Copy
    pasteSheet.Cells(lBlank, "A").PasteSpecial xlPasteValuesAndNumberFormats
    
    iCl = iCl + 1
    .Range(.Cells(lStRw, iCl), .Cells(lEndRw, iCl)).Copy
    pasteSheet.Cells(lBlank, "F").PasteSpecial xlPasteValuesAndNumberFormats
    
    iCl = iCl + 1
    .Range(.Cells(lStRw, iCl), .Cells(lEndRw, iCl)).Copy
    pasteSheet.Cells(lBlank, "P").PasteSpecial xlPasteValuesAndNumberFormats

    iCl = iCl + 1
    .Range(.Cells(lStRw, iCl), .Cells(lEndRw, iCl)).Copy
    pasteSheet.Cells(lBlank, "Q").PasteSpecial xlPasteValuesAndNumberFormats
    ActiveCell.PasteSpecial xlPasteFormats
End With

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

[wayneg]

Sixthsense, your code worked but it put some random formatting on my copysheet... i think i will stick with what i put in originally, but thank you for your help