PDA

View Full Version : Solved: Copy Specific Cell in Rows and Columns to Another Worksheet



coliervile
04-06-2008, 09:39 AM
I want a macro to be able to copy specific cells from rows and columns from worksheet "Tryouts" to worksheet "Players". On worksheet "Tryouts" I want to start in column "A4", "B4", "AN4" and copy down until the first empty cell in column "A" is reached and then paste the data into worksheet "Players" starting in column "A9", "B9", and C9" downward (e.g. "Tryouts"-cell "A4" gets copied to "Players"- cell "A9", "Tryouts"- cell "B4" gets copied to "Players"- cell "B9", and "Tryuots"- cell "AN4" gets copied to "Players"- cell "C9" untill the first empty cell in column "A" of worksheet "Tryouts" is reached).

Hopefully I was able to explain it well enough for you to help me with this issue???

lucas
04-06-2008, 09:56 AM
Here's one that should do what you ask Charlie
Sub copyCellsFromRow()
Dim i As Long
Dim Row As Long
Dim LastRow As Long

LastRow = Sheets("Tryouts").Range("A65536").End(xlUp).Row
Row = Sheets("Players").Range("A65536").End(xlUp).Row + 8
For i = 1 To LastRow
If Not Sheets("Tryouts").Range("A" & i).Text = "" Then
Sheets("Tryouts").Range("A" & i).Copy Destination:=Sheets("Players").Range("A" & Row)
Sheets("Tryouts").Range("B" & i).Copy Destination:=Sheets("Players").Range("B" & Row)
Sheets("Tryouts").Range("AN" & i).Copy Destination:=Sheets("Players").Range("C" & Row)
Row = Row + 1
End If
Next i
Sheets("Players").Select
Range("A10").Select
End Sub

coliervile
04-06-2008, 10:00 AM
This is what I'm using currently on worksheet "Players" to get the data from worksheet "Tryouts":

in cell "A9" in worksheet "Players" is:
=IF(Tryouts!$A4>0,Tryouts!$A4,"")


in cell "B9" in worksheet "Players" is:
=IF(Tryouts!$B4>0,Tryouts!$B4,"")


in cell "C9" in worksheet "Players" is:
=INDEX(Tryouts!$AN$4:$AN$204,MATCH($A9,Tryouts!$A$4:$A$204,39))

I would like a macro to make it cleaner and if there's a beter way or alternative to accomplish this???

lucas
04-06-2008, 10:01 AM
Change Lastrow and row lines to this for 2007 compatability:

LastRow = Sheets("Tryouts").Range("A" & Rows.Count).End(xlUp).Row
Row = Sheets("Players").Range("A" & Rows.Count).End(xlUp).Row + 8

lucas
04-06-2008, 10:05 AM
the code I submitted will copy the range specified if there is anything in column A......even a formula

coliervile
04-06-2008, 10:28 AM
Lucas thanks for replying. The macro you supplied didn't quite fullfill what I needed it to do. It copied row seven and down and then the headers at the top of the rows. I'm supplying the workbook (without your macro in it) to give you a better idea of what I need. If I change information on worksheet "Tryouts" and run the macro it needs to update the information on worksheet "Players".

tstav
04-06-2008, 10:32 AM
One more way to do it Charlie:
Sub CopyUntilFirstBlankCellInColumn()
Dim lastRow As Long
With Worksheets("Tryouts")
'Find the range to be copied from column A (from A4 until first blank cell is met)
lastRow = .Range("A4:A" & Rows.Count).SpecialCells(xlCellTypeBlanks).Cells(1).Row - 1
'Copy ranges
.Range("A4:A" & lastRow).Copy Worksheets("Players").Range("A9")
.Range("B4:B" & lastRow).Copy Worksheets("Players").Range("B9")
.Range("AN4:AN" & lastRow).Copy Worksheets("Players").Range("C9")
End With
End Sub

tstav
04-06-2008, 10:38 AM
In order to copy formulas as well as values, use the following
Sub CopyUntilFirstBlankCellInColumn()
Dim lastRow As Long
With Worksheets("Tryouts")
'Find first blank cell's row after A4
lastRow = .Range("A4:A" & Rows.Count).SpecialCells(xlCellTypeBlanks).Cells(1).Row - 1
'Copy ranges
Worksheets("Players").Range("A9").Value = .Range("A4:A" & lastRow).Value
Worksheets("Players").Range("B9").Value = .Range("B4:B" & lastRow).Value
Worksheets("Players").Range("C9").Value = .Range("AN4:AN" & lastRow).Value
End With
End Sub

tstav
04-06-2008, 10:41 AM
Don't mind me Charlie. I'm wrong.

lucas
04-06-2008, 10:53 AM
tstav If you get a minute look at this or my code.....I have a dinner to attend.....but I will be back Charlie......

tstav
04-06-2008, 11:13 AM
Hi Lucas,
I most certainly didn't mean to offend you. The copying from X to Y may be the same, but the finding of the first blank cell from A4 downwards is absolutely different (and that is was what I meant with "another way to do it"). The column might have gaps and I'm trying to cater for that.

The second code was wrong. OK. I'm sending the correct one right after this message.

Hope it's settled. Regards, tstav

lucas
04-06-2008, 11:13 AM
charlie, I have a minute while others are dressing....
try this....I did unprotect your players sheet manually......we can deal with that if we get the rest going our way.

lucas
04-06-2008, 11:15 AM
tstav, You most certainly did not offend me......the more input the better......I'm sure there is probably a better way and there is almost always more than one way to skin a cat.....

I just changed the lastrow bit:
For i = 1 To LastRow
to start on row 4
For i = 4 To LastRow

Edit:.....I forgot to change the 1 to a 4 in the second example.......

lucas
04-06-2008, 11:19 AM
The column might have gaps and I'm trying to cater for that.


I may be missing something here but the code I supplied will just skip blank cells in column A. In other words they will not be copied but if the next cells down contain data then they will be copied...

in other words if you clear contents for the number 9 on charlies example then the copied selection will go from 8 to 10 and continue on........

coliervile
04-06-2008, 11:23 AM
Lucas I did try your coding once again and had to make a couple of altercations. The code is not updating the current information it just keeps copying data below the current data. I've added a command button on worksheet "Players" to run the coding lease take a look. If it helps all I need the macr todo is copy the values of the cell from worksheet "Tryouts" and not the formatting. Thanks for your help with this.

lucas
04-06-2008, 11:56 AM
try this Charlie.....If I'm missing something please point it out.

As tstav may have pointed out.....this loop is ok if you don't have too many rows to deal with.....

coliervile
04-06-2008, 12:05 PM
Lucas that seems to have done the trick thank you so much for taking the time out and helping me solve this.

lucas
04-06-2008, 12:24 PM
good deal Charlie......be sure to mark it solved.

coliervile
04-06-2008, 12:49 PM
Lucas I was premature...I need the the cells copied from worksheet "Tryouts" to worksheet "Players" to only copy the cell values and nothing more. The workbook I provided you didn't have any formulas on the worksheet "Tryouts (to cut down on the file size to download). All I need is the cells values to be copied from worksheet "Tryouts" to worksheet "Players". Sorry about that I should have stated this earlier. How can I amend this part of the coding???

Sheets("Tryouts").Range("A" & i).Copy Destination:=Sheets("Players").Range("A" & Row)
Sheets("Tryouts").Range("B" & i).Copy Destination:=Sheets("Players").Range("B" & Row)
Sheets("Tryouts").Range("AN" & i).Copy Destination:=Sheets("Players").Range("C" & Row)
Row = Row + 1

tstav
04-06-2008, 01:00 PM
Since Lucas may be out to dinner at the moment, you may do the following change
If Not Sheets("Tryouts").Range("A" & i).Text = "" Then
' Sheets("Tryouts").Range("A" & i).Copy Destination:=Sheets("Players").Range("A" & Row)
Sheets("Players").Range("A" & Row).Value = Sheets("Tryouts").Range("A" & i).Value
' Sheets("Tryouts").Range("B" & i).Copy Destination:=Sheets("Players").Range("B" & Row)
Sheets("Players").Range("B" & Row).Value = Sheets("Tryouts").Range("B" & i).Value
' Sheets("Tryouts").Range("AN" & i).Copy Destination:=Sheets("Players").Range("C" & Row)
Sheets("Players").Range("C" & Row).Value = Sheets("Tryouts").Range("AN" & i).Value
Row = Row + 1
End If

lucas
04-06-2008, 01:06 PM
This seems to work Charlie
Sheets("Players").Range("A" & Row).Value = Sheets("Tryouts").Range("A" & i).Value
Sheets("Players").Range("B" & Row).Value = Sheets("Tryouts").Range("B" & i).Value
Sheets("Players").Range("C" & Row).Value = Sheets("Tryouts").Range("AN" & i).Value

lucas
04-06-2008, 01:07 PM
tstav......car is waiting but some of the gals are still primpin......

It's ceremonial rather than just a dinner......I don't like starting to get ready for dinner 3 hours before time......I love the women in my life but dang.....why can't people just spit in your palms and shake?

tstav
04-06-2008, 01:10 PM
Charlie as an alternative, and only if the 'Tryouts' Sheet does not contain any blank rows, you can use the following.
It does the copy in one sweep (rather than looping through rows)
It unprotects the 'Players' Sheet prior to copying values
It clears all cells in 'Players' Sheet (columns A,B,C from row 9 downwards) no matter how many rows
It resets Protection in the end

BUT (I repeat) it doesn't cater for blank rows in the 'Tryouts' Sheet. If such rows exist, they will be copied over as well.

Sub CopyCellsFromRow()
Dim LastRow As Long, allRows As Long
With ActiveWorkbook.Worksheets("Tryouts")

'Find last datarow in column A
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
'This is how many "rows" will be copied
allRows = LastRow - 4 + 1

'Remove protection
Worksheets("Players").Unprotect

'Clear Area
With Worksheets("Players")
'.Range(.Range("A9"), .Range("A" & .Rows.Count).End(xlUp)).Resize(, 3).ClearContents
.Range(.Range("A9"), .Range("A" & .Rows.Count)).Resize(, 3).ClearContents
End With

'Do the copy
Worksheets("Players").Range("A9").Resize(allRows).Value = .Range("A4").Resize(allRows).Value
Worksheets("Players").Range("B9").Resize(allRows).Value = .Range("B4").Resize(allRows).Value
Worksheets("Players").Range("C9").Resize(allRows).Value = .Range("AN4").Resize(allRows).Value

'Reset protection
Worksheets("Players").Protect Contents:=True
End With
End Sub

Check out the edit above (in the Clear Area comment).

tstav
04-06-2008, 01:13 PM
They sure take their time, don't they... Ha ha! Wish you have a great time Lucas!

coliervile
04-06-2008, 01:13 PM
"tstav" thank you so very much that worked perfectly. Thanks to Lucas and you for your help. :beerchug:

tstav
04-06-2008, 02:53 PM
.

tstav
04-06-2008, 02:55 PM
Glad to have helped. Nice "talking" to you, too, Charlie.
Sure wish I was out like Lucas, though.......

Anyways... For historical reasons I'm sending another piece of code that does the same job but it does it in bulk and skips blank rows. I mean it copies rows in blocks, depending on whether it finds any blank rows in between.

No blank rows and the copy-paste goes in one round.
1 blank row and you get 2 rounds, 2 blank rows and you get 3 rounds and so on...

Sub CopyCellsFromRow2()
'Copy Rows in Bulk, skipping all blank rows
Dim lastRow As Long, startRow As Long, newRow As Long, allRows As Long

'Remove protection and Clear Area
With Worksheets("Players")
.Unprotect
.Range(.Range("A9"), .Range("A" & .Rows.Count)).Resize(, 3).ClearContents
End With

On Error Resume Next
startRow = 4
Do
With Worksheets("Tryouts")
'Find last non-blank-cell's row (column A)
'An error will be raised if no blank cell is found
lastRow = .Range("A" & startRow & ":A" & Rows.Count).SpecialCells(xlCellTypeBlanks).Cells(1).Row - 1
If Err Then 'no blanks found. Find the last dataRow
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
End If
'This is the number of rows to copy
allRows = lastRow - startRow + 1
'This is the row to paste to
With Worksheets("Players")
newRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With
'Do the copy-paste
Worksheets("Players").Range("A" & newRow).Resize(allRows).Value = .Range("A" & startRow).Resize(allRows).Value
Worksheets("Players").Range("B" & newRow).Resize(allRows).Value = .Range("B" & startRow).Resize(allRows).Value
Worksheets("Players").Range("C" & newRow).Resize(allRows).Value = .Range("AN" & startRow).Resize(allRows).Value
'Find next non-empty cell in column A
startRow = .Range("A" & lastRow).End(xlDown).Row
End With
Loop Until Err
'Reset protection
Worksheets("Players").Protect Contents:=True
End Sub

coliervile
04-06-2008, 05:24 PM
Wow a lot of variations on this topic. I'll take a look through the to see if there's any real differences. Thanks again for your help "tstav" and Lucas. Lucas enjoy your dinner if you ever get the women out of there...:devil2:

tstav
04-07-2008, 04:24 AM
Hi Charlie,
I'm back because sth came up.
As I was using my code of post#27 in something else I'm currently doing, I noticed that the error in line
lastRow = .Range("A" & startRow & ":A" & Rows.Count).SpecialCells(xlCellTypeBlanks).Cells(1).Row - 1
is not raised whatsoever and of course the code fails.
I'm trying to see why. This error did occur in numerous tests I did yesterday and everything worked fine, that's why I decided to post it.

Until I find what the problem is, please refrain from using this code.

You can always use the other codes, Lucas and I have posted.

I'll get back to you.

P.S. If you or anybody else has already tried this code, I'd be glad to have any feed back.

Regards, tstav

Edit: Apologies for the wrong name (see red name above)

coliervile
04-07-2008, 01:32 PM
Thanks "tstav" thanks for the heads up with the possible error in the code. Have a good day.

Best regards,

Charlie

tstav
04-07-2008, 01:54 PM
Hi Charlie,
I have found the error and fixed it but I haven't posted anything yet cause I'm coming up with a newer version that caters for numerous things.
May be much more than what you are asking for (since you only want to copy about 140 lines). But I'll post it anyway...

In the meantime I hope you've noticed the minor change in my post#23.
If you haven't, you can check it out now. It concerns the clean-up of the 'Players' sheet. I guess I must have been half asleep to miss out on sth like that (it was past midnight here when I posted it and I had been working for over 14 hours straight... Oh, and Lucas was going out to dinner :thumb ...)

tstav
04-07-2008, 02:53 PM
Here it is... and don't let the size of it put you off...
It copies data from a Sheet filled to the last row, skipping rows that have a blank cell in a specific column.
It is super fast compared to the row by row approach and if one turns screenupdating off it goes even faster (everything does when screen is off).
The way it works is like so:
It finds all blank cells in column e.g. "A" and stores the relevant rows to an array. These rows act as "separator lines" separating one set of data from the next one.
All that's left to do after that is copy each set of data from one Sheet to the other.
I don't know if I can call the testing I've done so far 'exhaustive', but I know I'm exhausted...:p . Still, I'm happy it finally came through.
Hope someone will test it and let me know if sth comes up...

Best regards Charlie (it's way past midnight again.....................)
Sub CopyRangesSkippingRowsWithBlankCell()
'------------------------------------------------------------------------------------------
'Copy data from one Sheet to another, skipping rows that have blank cell in specific column
'To be used preferably for copying very large numbers of rows
'------------------------------------------------------------------------------------------
Const Col As String = "A" ' <-- This is the column that may contain blank cells <-- Change to suit
Const fromSheet As String = "Tryouts" ' <-- Change to suit
Const toSheet As String = "Players" ' <-- Change to suit
Dim startRow As Long, endRow As Long, newRow As Long, allRows As Long
Dim blank() As Long, count As Long, i As Long
Dim rng As Range, cel As Range
'Application.ScreenUpdating = False
'--------------------------------
'Clear Area to accept the data
'--------------------------------
With Worksheets(toSheet)
.Unprotect
.Range(.Range("A9"), .Range("A" & .Rows.count)).Resize(, 3).ClearContents
End With
'---------------------------------------------------
'Store the rows with a blank cell in column Col
'These rows separate one block of data from the next
'---------------------------------------------------
startRow = 4
With Worksheets(fromSheet)
'Find where the data ends (check column Col)
endRow = IIf(.Range(Col & .Rows.count).Value <> "", .Rows.count, .Range(Col & .Rows.count).End(xlUp).Row)
'This is the total range in column Col that will be copied
Set rng = Worksheets(fromSheet).Range(Col & startRow & ":" & Col & endRow)

'Store the startRow - 1 (first 'separator line'-doesn't matter if it's blank or not)
count = count + 1
ReDim blank(1 To count) 'make it 1-based
blank(count) = startRow - 1
On Error Resume Next
'Get all the blank cells of the above range
Set rng = rng.SpecialCells(xlCellTypeBlanks)
'Store the row of each blank cell
If Err Then
Err.Clear
Else
For Each cel In rng
count = count + 1
ReDim Preserve blank(1 To count)
blank(count) = cel.Row
Next
End If
On Error GoTo 0
'Store the endRow + 1 (last 'separator line'-doesn't matter if it's blank or not)
count = count + 1
ReDim Preserve blank(1 To count)
blank(count) = endRow + 1

'-------------------------------------------------------
'Do the copy/paste of the ranges between the stored rows
'-------------------------------------------------------
For i = LBound(blank) + 1 To UBound(blank)
'Skip consecutive 'separator lines'
If blank(i) - blank(i - 1) > 1 Then
'This is the number of rows to copy
allRows = blank(i) - blank(i - 1) - 1
With Worksheets(toSheet)
'If sheet is full, stop the copy
If .Range("A" & .Rows.count).Value <> "" Then
MsgBox "No more available rows to accept data. Exiting..."
Exit For
End If
'This is the row to paste to
newRow = .Range("A" & .Rows.count).End(xlUp).Row + 1
'If not enough available rows to accept all data, copy as many rows can fit
If .Rows.count - newRow + 1 < allRows Then
MsgBox "Not enough available rows. " & allRows - (.Rows.count - newRow + 1) & " row(s) will not be copied."
allRows = .Rows.count - newRow + 1
End If
End With
'Do the copy-paste.
'For x consequtive columns, change the "Resize(allRows)" to "Resize(allRows, x)"
'For non-consequtive columns, add more lines with "Resize(allRows)"
Worksheets(toSheet).Range("A" & newRow).Resize(allRows, 2).Value = .Range("A" & blank(i - 1) + 1).Resize(allRows, 2).Value
Worksheets(toSheet).Range("C" & newRow).Resize(allRows).Value = .Range("AN" & blank(i - 1) + 1).Resize(allRows).Value
End If
Next
End With
'Reset Protection
Worksheets(toSheet).Protect Contents:=True
'Application.ScreenUpdating = True
End Sub

Edit April 8: Minor comment additions.

coliervile
04-07-2008, 04:38 PM
"tstav" WOW WHAT A MASTER PIECE! You went above and beyond.... :bow: That's an absolutely wonderful coding you came up with. I'm always in awe and admiration of folks like yourself that devote your spare time to help everyone out and the unlimited ways of perform one function. I couldn't have even imagined in a hundred years of thinking of the coding you came up with. I've been told before that "it's just coding" (right "xld"- Bob) but it truly amazing the level you folks are able to think on because of your expertise to come up with a solution. What else can I say but THANKS "TSTAV". :clap: :thumb Have an Ouzo on me and enjoy a well deserved rest.
:beerchug:

And yes I did notice the suddle change in thread #23.

lucas
04-07-2008, 05:03 PM
He did not know it was impossible, so he did it

tstav
04-07-2008, 11:32 PM
Thanks guys, it's always nice to know one's work has been appreciated.

Good day to both of you :beerchug: