Copy heading and name to applicable sheet

[howard]

I have names in Col O in Sheet2


I need the header in (O1) as well as the name in Col O to be copied to Z1 on the applicable sheet for eg BR1 on Col O as well as the heading to be copied to Sheet BR1 Z1.


it would be appreciated if someone could kindly provide me with code to do this

Book1
	O
1	Branch Name
2	BR1
3	BR2
4	BR3
5	BR4
6	BR5
7	BR6
8	BR7
9	BR8
10	BR9
11	BR10
12	BR11
13	BR12
Sheet2

 

[mumps]

Try:

Sub CopyCells()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim rng As Range
    For Each rng In Range("O2:O" & LastRow)
        Sheets(rng.Value).Range("Z1") = Cells(1, "O") & " " & rng
    Next rng
    Application.ScreenUpdating = True
End Sub

 

[howard]

Thanks for the help, much appreciated

 

[mumps]

You are very welcome.

 

[howard]

Hi Mumps


I have a similar problem on Sheet2 where I have the names of the sheets in Col W and email address in the first 3 rows below the relevant sheet name. These are to be copied into AA! in the relevant sheet name

See sample data below


for eg Admin Staff and email addreses 3 rows below to be copied to AA! on sheet admin staff, Sales Staff and email address 3 rows below to be copied to sheet admin staff in AA1

Book1
	W
1	Sales Staff
2	dav@mac.com
3	lau@mac.com
4	nig@mac.com
5
6	Admin Staff
7	Ste@mac.com
8	pet@mac.com
Sheet2

i have tried to amend your code, but get a syntax error

  Sheets(rng.Value).Range("AA1") = Cells.Resize(3,(23, "V") & " " & rng

 Sub CopyEmail_AddressestoRelevantSheets()
  Sheets(2).Select
   Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim rng As Range
    For Each rng In Range("W1:W" & LastRow)
        Sheets(rng.Value).Range("AA1") = Cells.Resize(3,(23, "V") & " " & rng
    Next rng
    Application.ScreenUpdating = True
End Sub

Kindly check & amend the code

 

[mumps]

Try:

Sub CopyCells2()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim x As Long, rng As Range
    For x = 2 To LastRow Step 5
        Range("W" & x).Resize(3).Copy Sheets(Range("W" & x - 1).Value).Range("AA1")
        For Each rng In Sheets(Range("W" & x - 1).Value).Range("AA1").Resize(3)
            rng = Range("W" & x - 1) & " " & rng
        Next rng
    Next x
    Application.ScreenUpdating = True
End Sub

 

[howard]

Hi Mumps


I get subscript out of range when running the macro


Would you like me to email you a smple file ? if so send me a PM

 Range("W" & x).Resize(3).Copy Sheets(Range("W" & x - 1).Value).Range("AA1")

 

[mumps]

Instead of using email, perhaps you could upload a copy of your file to a free site such as www.box.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. If the workbook contains confidential information, you could replace it with generic data.

 

[howard]

see link below for shared file


https://app.box.com/s/wprxsqrlbqrg4nvxduyxzx20990ggmpe

 

[mumps]

The macro assumes that there will always be 3 blank rows between each set of email addresses. If this is not the case, then please upload a workbook with enough sample data to show how your data is organized.

Sub CopyCells2()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim x As Long, rng As Range
    For x = 2 To LastRow Step 7
        Range("W" & x).Resize(3).Copy Sheets(Range("W" & x - 1).Value).Range("AA1")
        For Each rng In Sheets(Range("W" & x - 1).Value).Range("AA1").Resize(3)
            rng = Range("W" & x - 1) & " " & rng
        Next rng
    Next x
    Application.ScreenUpdating = True
End Sub