View Full Version : Solved: Loop through and Copy
Odyrus
05-09-2011, 07:32 AM
Hello all!
First I'd to thank all of you for this forum, there's a lot of great information here! Thanks!
I'm some what of a VB novice but I've learned a lot by reading through code and playing with things. One thing I'm having trouble with is creating some code that loops through all the sheets in my workbook, except for sheets 1 and 2, and copies a specific range, BO45, from all of them to my roll up sheet ("rollup").
Any thoughts?
I appreciate any assistance!
Greetings Odyrus,
Welcome to vbaexpress :-)
I wasn't sure, but guessed that 'Rollup' would also be discluded.
Option Explicit
Sub exa2()
Dim wks As Worksheet
For Each wks In ThisWorkbook.Worksheets
If Not (wks.Name = "Rollup" Or wks.Name = "Sheet1" Or wks.Name = "Sheet2") Then
ThisWorkbook.Worksheets("Rollup").Cells(Rows.Count, "A").End(xlUp).Offset(1).Value _
= wks.Range("BO45").Value
End If
Next
End Sub
Hope that helps,
Mark
ntrauger
05-09-2011, 08:00 AM
Same song, different melody:Sub a()
Dim iCount As Long
Dim rDest As Range
If Sheets.Count < 3 Then Exit Sub 'Pre-emptive error checking
Set rDest = Sheets("rollup").Range("A1") 'Preset destination cell of copy method
For iCount = 3 To Sheets.Count 'Loop through all sheets except the first 2
If Sheets(iCount).Name <> "rollup" Then 'Assuming "rollup" sheet should be excluded _
' and may not be among first 2 sheets
Sheets(iCount).Range("BO45").Copy rDest 'Copy to preset cell on "rollup" sheet
Set rDest = rDest.Offset(1) 'Move destination cell one row down
End If
Next
End Sub
Odyrus
05-09-2011, 08:22 AM
I've noticed there is usually more than one way to a skin a cat when it comes to programming something in VB. Cheers!
Odyrus
05-18-2011, 07:39 AM
Hello again,
The code provided proved to be very helpful, thanks. I'm trying to revise it to include more than one value into the corresponding range on my rollup with out any luck. (Kind of like concatenating).
Appreciate any feedback.
Here's the code I'm not having luck with:
For Each wks In ThisWorkbook.Worksheets
If Not (wks.Name = "Rollup" Or wks.Name = "Sheet1" Or wks.Name = "Sheet2") Then
ThisWorkbook.Worksheets("Summary").Cells(Rows.Count, "A").End(xlUp).Offset(1).Value _
= wks.Range("K49" & "K50").Value
cheers!
Hi there,
No testing, but I believe that this would solve.
For Each wks In ThisWorkbook.Worksheets
If Not (wks.Name = "Rollup" Or wks.Name = "Sheet1" Or wks.Name = "Sheet2") Then
ThisWorkbook.Worksheets("Summary").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(2).Value _
= wks.Range("K49:K50").Value
Note the difference in the argument supplied to .Range, and that we need to .Resize the destination cells, as you are now grabbing two cells.
Odyrus
05-20-2011, 06:09 AM
Hey GTO, thanks for the response!
I didn't think to resize the destination cells, good call.
However, I did try listing the range as your solution states (K49:K50) and in both cases (K49:K50 and K49 & K50) I'm still getting just the value for K49.
I added the resize component to the code and I'm still just getting one value. It's a conundrum for me for sure!
Thoughts?
Cheers!
I just tested this exact code in a Standard Module and it works.
Option Explicit
Sub exa()
Dim wks As Worksheet
For Each wks In ThisWorkbook.Worksheets
If Not (wks.Name = "Rollup" Or wks.Name = "Sheet1" Or wks.Name = "Sheet2") Then
ThisWorkbook.Worksheets("Summary").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(2).Value _
= wks.Range("K49:K50").Value
End If
Next
End Sub
Odyrus
05-20-2011, 06:29 AM
It does work, gratitude!
One question though, is it not possible to copy those contents into the same cell like concatenate?
Thanks for the assistance
:thumb
Sorry, I misunderstood that part. Okay, no resizing if its going in one cell from two...
Sub exa()
Dim wks As Worksheet
For Each wks In ThisWorkbook.Worksheets
If Not (wks.Name = "Rollup" Or wks.Name = "Sheet1" Or wks.Name = "Sheet2") Then
ThisWorkbook.Worksheets("Summary").Cells(Rows.Count, "A").End(xlUp).Offset(1).Value _
= wks.Range("K49").Value & Chr(32) & wks.Range("K50").Value
End If
Next
End Sub
Odyrus
05-20-2011, 11:15 AM
Ah... that makes total sense now! Thanks for the help!
Cheers!
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.