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

[lucas]

This seems to work Charlie
[VBA]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[/VBA]

[lucas]

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]

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.

[vba]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[/vba]

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

[tstav]

They sure take their time, don't they... Ha ha! Wish you have a great time Lucas!

[coliervile]

"tstav" thank you so very much that worked perfectly. Thanks to Lucas and you for your help.

[tstav]

.

[tstav]

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...

[vba]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[/vba]

[coliervile]

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...

[tstav]

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
[vba]lastRow = .Range("A" & startRow & ":A" & Rows.Count).SpecialCells(xlCellTypeBlanks).Cells(1).Row - 1[/vba]
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]

Thanks "tstav" thanks for the heads up with the possible error in the code. Have a good day.

Best regards,

Charlie

[tstav]

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 ...)

[tstav]

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... . 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.....................)
[vba]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
[/vba]
Edit April 8: Minor comment additions.

[coliervile]

"tstav" WOW WHAT A MASTER PIECE! You went above and beyond.... 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". Have an Ouzo on me and enjoy a well deserved rest.


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

[lucas]

He did not know it was impossible, so he did it

[tstav]

Thanks guys, it's always nice to know one's work has been appreciated.

Good day to both of you