EXCEL1: Copy from multiple sheets (26), PASTE to 1 sheet from 26 sheets

[aacod]

I have a workbook with 26 sheets, labelled A to Z. Column A in all the sheets have names from rows A6:A35.

I need a macro or a code to extract all the names from each of the 26 sheets and paste it to a new sheet 'Names' under column A, such that names starting with 'B' paste under all the names 'A' and so forth till 'Z'.
Thanks .

 

[jeffreybrown]

Here are some pre-built macros that might do exactly what you need...

http://www.rondebruin.nl/copy2.htm

 

[VoG]

Try

Sub AppendData()
Dim ws As Worksheet, LR As Integer
Application.ScreenUpdating = False
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Names"
For Each ws In ThisWorkbook.Worksheets
    With ws
        If .Name <> "Names" Then .Range("A6:A35").Copy Destination:=Sheets("Names").Range("A" & Rows.Count).End(xlUp).Offset(1)
    End With
Next ws
With Worksheets("Names")
    .Rows(1).Delete
    LR = .Range("A" & Rows.Count).End(xlUp).Row
    .Range("A1:A" & LR).Sort Key1:=Range("A1"), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[aacod]

Thank Peter & Jeff.

I have used Peter's code which meets my need right now.
Jeff, I will try the codes from the link that has been provided by you.

 

[aacod]

Peter,

Would apreciate if you could add a function to the following code to DELETE all Blank ROWSfrom 'NAMES' sheet, and also if there is no text in cloumn 'A' Delete the whole ROW from 'NAMES' Sheet.

Sub AppendData()
Dim ws As Worksheet, LR As Integer
Application.ScreenUpdating = False
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Names"
For Each ws In ThisWorkbook.Worksheets
    With ws
        If .Name <> "Names" Then .Range("A6:A35").Copy Destination:=Sheets("Names").Range("A" & Rows.Count).End(xlUp).Offset(1)
    End With
Next ws
With Worksheets("Names")
    .Rows(1).Delete
    LR = .Range("A" & Rows.Count).End(xlUp).Row
    .Range("A1:A" & LR).Sort Key1:=Range("A1"), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[VoG]

Try this

Sub AppendData()
Dim ws As Worksheet, LR As Integer
Application.ScreenUpdating = False
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Names"
For Each ws In ThisWorkbook.Worksheets
    With ws
        If .Name <> "Names" Then .Range("A6:A35").Copy Destination:=Sheets("Names").Range("A" & Rows.Count).End(xlUp).Offset(1)
    End With
Next ws
With Worksheets("Names")
    On Error Resume Next
    .Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
    LR = .Range("A" & Rows.Count).End(xlUp).Row
    .Range("A1:A" & LR).Sort Key1:=Range("A1"), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[aacod]

Thanks Peter, this works perfect!

 

[aacod]

Peter,

Is there a way to do the following from all the 26 sheets:

Extract the names from column A as above and extract the corresponding emails from column F, leaving behind the columns inbetween.

Inshort,
place the emails from column F, against the names in column A from all the 26 sheets in a new sheet 'NAMES' retaining all the functions of the last code.

Thanks

 

[VoG]

Try this

Sub AppendData()
Dim ws As Worksheet, LR As Integer
Application.ScreenUpdating = False
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Names"
For Each ws In ThisWorkbook.Worksheets
    With ws
        If .Name <> "Names" Then
            .Range("A6:A35").Copy Destination:=Sheets("Names").Range("A" & Rows.Count).End(xlUp).Offset(1)
            .Range("F6:F35").Copy Destination:=Sheets("Names").Range("B" & Rows.Count).End(xlUp).Offset(1)
        End If
    End With
Next ws
With Worksheets("Names")
    On Error Resume Next
    .Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
    LR = .Range("A" & Rows.Count).End(xlUp).Row
    .Range("A1:B" & LR).Sort Key1:=Range("A1"), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[aacod]

Thanks Peter, Works absolutely as I wanted.