Copy specific column on multiple sheets to one column on another sheet

[jconkl02]

I have a workbook that has 9 worksheets that are always there and then a varying number of worksheets that will be included after the original nine.

What I am trying to do is copy columns A and F (from the 2nd row down to the last cell with a value) from each of the worksheets after the original nine. Then I want to paste the data from each of those worksheets into the next available cell of columns A and F on a worksheet called "AllDown"

I had tried using this method but it never copied any data into the "AllDown" sheet:

Dim sheet As Worksheet
For Each sheet In ActiveWorkbook.Worksheets
If sheet.Index > 9 Then
ActiveSheet.Range("A2:A300").Select
Selection.Copy

Sheets("AllDown").Select
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

End If
Next

Any assistance is appreciated.

 

[wideboydixon]

Untested but give this a try:

Public Sub CopyAandF()

Dim thisSheet As Long
Dim lastRow As Long
Dim thisCol As Long

If Sheets.Count < 10 Then Exit Sub

For thisSheet = 10 To Sheets.Count
    With Sheets(thisSheet)
        For thisCol = 1 To 6 Step 5
            lastRow = .Cells(.Rows.Count, thisCol).End(xlUp).Row
            .Range(.Cells(2, thisCol), .Cells(lastRow, thisCol)).Copy Sheets("AllDown").Cells(Sheets("AllDown").Rows.Count, thisCol).End(xlUp).Offset(1, 0)
        Next thisCol
    End With
Next thisSheet

End Sub

WBD

 

[jconkl02]

Getting there. Your code pulls everything for Column A but nothing for Column F.

Also, I didn't state this earlier but I need the data pasted special as values.

Thanks,
Jason

 

[Dryver14]

wideboy, why step 5?

 

[emukiss10]

try this

it adds new sheet "AllDown and copy A:F from each sheet to it

    Sheets.Add(After:=Sheets(Sheets.count)).Name = "AllDown"


    
    For Each Sh In Worksheets
      If Sh.Name <> "AllDown" Then
        Sh.Activate
      End If


    Dim LR As Long
    LR = Range("A" & Rows.count).End(xlUp).row
    
    Range("A2:F" & LR).Select
    Selection.Copy Sheets("AllDown").Range("A" & Rows.count).End(xlUp).Offset(1)


    Next Sh

 

[emukiss10]

With Paste as Values

    Sheets.Add(After:=Sheets(Sheets.count)).Name = "AllDown"


    
    For Each Sh In Worksheets
      If Sh.Name <> "AllDown" Then
        Sh.Activate
      End If


    Dim LR As Long
    LR = Range("A" & Rows.count).End(xlUp).row
    
    Range("A2:F" & LR).Select
    Selection.Copy Sheets("AllDown").Range("A" & Rows.count).End(xlUp).Offset(1)


    Next Sh

[FONT=Verdana]      Sheets("AllDown").Range("A2:F" & LR).Copy[/FONT]
[FONT=Verdana]      Sheets("AllDown").Range("A2:F" & LR).PasteSpecial xlPasteValues[/FONT]
[FONT=Verdana]      Application.CutCopyMode = False
[/FONT]

 

[wideboydixon]

Sorry - I didn't see the reply. Amended code below:

Public Sub CopyAandF()

Dim thisSheet As Long
Dim lastRow As Long
Dim thisCol As Long

If Sheets.Count < 10 Then Exit Sub

For thisSheet = 10 To Sheets.Count
    With Sheets(thisSheet)
        For thisCol = 1 To 6 Step 5
            lastRow = .Cells(.Rows.Count, thisCol).End(xlUp).Row
            .Range(.Cells(2, thisCol), .Cells(lastRow, thisCol)).Copy
            Sheets("AllDown").Cells(Sheets("AllDown").Rows.Count, thisCol).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
        Next thisCol
    End With
Next thisSheet

Application.CutCopyMode = False

End Sub

This line:

        For thisCol = 1 To 6 Step 5

Processes columns A and F (1 and 6) and I've tested it locally where it appears to be working. Can you let me know if it works with the new modifications?

Thanks,

WBD

 

[jconkl02]

WBD,

It is working nearly perfect. The only hiccup is that if Column A or F does not have any data, the macro is copying and pasting the header cell into AllDown.

Jason

 

[wideboydixon]

Public Sub CopyAandF()

Dim thisSheet As Long
Dim lastRow As Long
Dim thisCol As Long

If Sheets.Count < 10 Then Exit Sub

For thisSheet = 10 To Sheets.Count
    With Sheets(thisSheet)
        For thisCol = 1 To 6 Step 5
            lastRow = .Cells(.Rows.Count, thisCol).End(xlUp).Row
            If lastRow > 1 Then
                .Range(.Cells(2, thisCol), .Cells(lastRow, thisCol)).Copy
                Sheets("AllDown").Cells(Sheets("AllDown").Rows.Count, thisCol).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
            End If
        Next thisCol
    End With
Next thisSheet

Application.CutCopyMode = False

End Sub

WBD