For Each loop

[Michael Smith]

I have a workbook with multiple worksheets. My "MAIN" sheet has Names
in column A, and Sales data in Columns B and C.
The other worksheets are titled after column A. I want to cycle through
the names on my MAIN sheet and copy the data to the worksheet matching
the name in column A.

Please help me with this For Each loop.


*** Sent via Developersdex http://www.developersdex.com ***

 

[Toppers]

Michael,
Copies data to columns A & B on named worksheets.

Change wks2.Range("a" & nr) to wks2.Range("b" & nr) if B required.

HTH

Sub CopyToSheets()

Dim lastrow As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Dim Wks

Set ws1 = ThisWorkbook.Worksheets("MAIN")
ws1.Activate
With ws1
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
For r = 2 To lastrow
Set wks2 = Worksheets(Cells(r, 1).Value)
nr = wks2.Cells(Rows.Count, 1).End(xlUp).Row + 1
ws1.Cells(r, 1).Offset(0, 1).Resize(1, 2).Copy wks2.Range("a" & nr)
Next r
End With
End Sub

 

[Michael Smith]

Thank you, thank you!..that works wonderfully....one last question that
I probably should have included in the original post, if the
worksheet(Name in column A) doesn't exist, how would i get it to create
a new worksheet with that name.
Thanks again, i was on the wrong track before your help.
-Mike



*** Sent via Developersdex http://www.developersdex.com ***

 

[Dave Peterson]

Debra Dalgleish and Ron de Bruin have samples that you may like. Ron's addin
may be sufficient right out of the box.

Debra's site:
http://www.contextures.com/excelfiles.html

Create New Sheets from Filtered List -- uses an Advanced Filter to create
separate sheet of orders for each sales rep visible in a filtered list; macro
automates the filter. AdvFilterRepFiltered.xls 35 kb

or

Update Sheets from Master -- uses an Advanced Filter to send data from
Master sheet to individual worksheets -- replaces old data with current.
AdvFilterCity.xls 55 kb

And Ron de Bruin's easyfilter.
http://www.rondebruin.nl/easyfilter.htm

 

[Toppers]

Michael,
Try this. Function routine is courtesy of Bob Phillips from a
previous posting.

Sub CopyToSheets()

Dim lastrow As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Dim Wks

Set ws1 = ThisWorkbook.Worksheets("MAIN")
ws1.Activate
With ws1
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
For r = 2 To lastrow
If Not SheetExists(.Cells(r, 1)) Then
Set NewWS = Worksheets.Add
NewWS.Name = .Cells(r, 1)
End If
Set wks2 = Worksheets(.Cells(r, 1).Value)
nr = wks2.Cells(Rows.Count, 1).End(xlUp).Row + 1
ws1.Cells(r, 1).Offset(0, 1).Resize(1, 2).Copy wks2.Range("a" & nr)
Next r
End With
End Sub
'-----------------------------------------------------------------
Function SheetExists(Sh As String, _
Optional wb As Workbook) As Boolean
'-----------------------------------------------------------------
Dim oWs As Worksheet
If wb Is Nothing Then Set wb = ActiveWorkbook
On Error Resume Next
SheetExists = CBool(Not wb.Worksheets(Sh) Is Nothing)