简体   繁体   中英

How to copy sheets with certain tab color from one workbook to another?

I have several Workbooks where there are several sheets that have Tab color with RGB code (0,255,0) ie completely green so I need to copy only these sheets to ActiveWorkbook without opening workbooks containing these green sheets

Sub Copy_Green_Sheets()
Dim wb As Workbook
Dim ws As Worksheet

If ws.Tab.Color = RGB(0, 255, 0) Then
         Set wb = Workbooks("Target workbook")
         For Each ws In Workbooks("source workbook").Worksheets
         ws.Copy After:=wb.Sheets(wb.Sheets.Count)
         Next ws
End If
End Sub
Option Explicit

Sub DoItForAllWorkbooks()
    Dim myWorkbook As Workbook
    Dim myWbFullNames(100) As String
    Dim iCt As Integer

    ' You might to want to create such a list with Excel:
    '="'        myWbFullNames("&B3&") = ""C:\mySpecialFolder\myFile0"&B3&".xlsx"""

    myWbFullNames(1) = "C:\mySpecialFolder\myFile01.xls"
    myWbFullNames(2) = "C:\mySpecialFolder\myFile02.xls"
    myWbFullNames(3) = "C:\mySpecialFolder\myFile03.xls"
    myWbFullNames(4) = "C:\mySpecialFolder\TabColor4.xlsx"
    myWbFullNames(5) = "C:\mySpecialFolder\myFile05.xls"

    For iCt = 1 To 5
        Workbooks.Open myWbFullNames(iCt)
        Set myWorkbook = ActiveWorkbook
        Call Copy_Green_Sheets_NEW(ActiveWorkbook)
        myWorkbook.Close
    Next iCt
End Sub

Sub Copy_Green_Sheets_NEW(SourceWorkbook as workbook)
Dim wb As Workbook
Dim ws As Worksheet
    Set wb = Workbooks("Target workbook")
    'For Each ws In Workbooks("source workbook").Worksheets --- OLD
    For Each ws In SourceWorkbook.Worksheets
        If ws.Tab.Color = RGB(0, 255, 0) Then
            ws.Copy After:=wb.Sheets(wb.Sheets.Count)
        End If
    Next ws
End Sub

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM