Sheet Copying

[pells]

I have a workbook with many worksheets. I am trying to copy all of the worksheet where the Tab.ColorIndex = 4 via code, but am completely stuck.

Does anyone know or able to help me where if the Tab.ColorIndex = 4 across any of the sheets then copy this sheet to a new workbook. There will be many worksheets where the Tab.ColorIndex = 4, so I need to code to be able to find all of them and copy the sheet as well as the tab name? I can copy the sheets successfully if I manually name my code to reflect the sheet names but the code is too long and if the sheetname changes, the code fails.

Many thanks for taking the time to read my post and many thanks for any help/assistance that can be given.

 

[pells]

Do you want to overwrite the sheets in the destination workbook or to append?

Append.

 

[VoG]

Try

Sub a()
Dim i As Long, wb As Workbook, s As String
Set wb = Workbooks("Book1.xlsm")
With wb
    For i = 1 To .Sheets.Count
        If .Sheets(i).Tab.ColorIndex = 4 Then
            s = .Sheets(i).Name
            If WorksheetExists(ThisWorkbook.Name, s) Then
                .Sheets(i).UsedRange.Copy Destination:=ThisWorkbook.Sheets(s).Range("A" & Rows.Count).End(xlUp).Offset(1)
            End If
        End If
    Next i
End With
End Sub

Function WorksheetExists(WBName As String, WSName As String) As Boolean
On Error Resume Next
WorksheetExists = Workbooks(WBName).Worksheets(WSName).Name = WSName
End Function

 

[pells]

Try

Sub a()
Dim i As Long, wb As Workbook, s As String
Set wb = Workbooks("Book1.xlsm")
With wb
    For i = 1 To .Sheets.Count
        If .Sheets(i).Tab.ColorIndex = 4 Then
            s = .Sheets(i).Name
            If WorksheetExists(ThisWorkbook.Name, s) Then
                .Sheets(i).UsedRange.Copy Destination:=ThisWorkbook.Sheets(s).Range("A" & Rows.Count).End(xlUp).Offset(1)
            End If
        End If
    Next i
End With
End Sub

Function WorksheetExists(WBName As String, WSName As String) As Boolean
On Error Resume Next
WorksheetExists = Workbooks(WBName).Worksheets(WSName).Name = WSName
End Function

wow, many thanks for this.

Apologies but I forgot that I have password protection on the sheet thats I am trying to copy from and to and I also need to pastespecial as there are formulas that need copying - is this possible?

Many thanks for all your help with this.

 

[VoG]

Try

Sub a()
Dim i As Long, wb As Workbook, s As String
Set wb = Workbooks("Book1.xlsm")
With wb
    For i = 1 To .Sheets.Count
        If .Sheets(i).Tab.ColorIndex = 4 Then
            s = .Sheets(i).Name
            If WorksheetExists(ThisWorkbook.Name, s) Then
                ThisWorkbook.Sheets(s).Unprotect
                .Sheets(i).UsedRange.Copy
                ThisWorkbook.Sheets(s).Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
                ThisWorkbook.Sheets(s).Protect
            End If
        End If
    Next i
End With
End Sub

Function WorksheetExists(WBName As String, WSName As String) As Boolean
On Error Resume Next
WorksheetExists = Workbooks(WBName).Worksheets(WSName).Name = WSName
End Function

 

[pells]

Try

Sub a()
Dim i As Long, wb As Workbook, s As String
Set wb = Workbooks("Book1.xlsm")
With wb
    For i = 1 To .Sheets.Count
        If .Sheets(i).Tab.ColorIndex = 4 Then
            s = .Sheets(i).Name
            If WorksheetExists(ThisWorkbook.Name, s) Then
                ThisWorkbook.Sheets(s).Unprotect
                .Sheets(i).UsedRange.Copy
                ThisWorkbook.Sheets(s).Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
                ThisWorkbook.Sheets(s).Protect
            End If
        End If
    Next i
End With
End Sub

Function WorksheetExists(WBName As String, WSName As String) As Boolean
On Error Resume Next
WorksheetExists = Workbooks(WBName).Worksheets(WSName).Name = WSName
End Function

Fantastic - this works perfectly!

Many thanks for all your help, you are a complete star.