Stuck on creating VBA script if and else?????

[exceljen86]

Hi all,

I have and "input" sheet in my workbook with a table like this

Type 1	Y
Type 2
Type 3

<tbody>
</tbody>

I want to use it so that every "Y" put in the right column would select certain sheets and then at the end it would copy all of the sheets into a new workbook.

but every way I try I come up blank. I thought of just using if and else and putting every scenario in, but that would take forever. Anyone have any ideas please?

 

[Comfy]

Can you provide more comprehensive data?

Is column 1 in your example your sheet names or do the identify a collection of sheet names?

 

[exceljen86]

Hi comfy,

Column 1 is just a list of names.

This is one that I tried, but it only selects the sheets for each "if" statement (and for some reason only copies the first sheet selected). It's like I need to be able to put Andif instead of elseif

Sub Macro2()
'
' Macro2 Macro
'


'
    If activesheet.range("B3") = "Y" Then
    Sheets(Array("1.02", "1.04")).Select
    
    ElseIf [FONT=Verdana]activesheet.range[/FONT][FONT=Verdana]("B4") = "Y" Then[/FONT]
    Sheets(Array("1.03")).Select
    End If
    ActiveWorkbook.ActiveSheet.Copy
End Sub

Or I maybe heading down the wrong path completely

 

[Comfy]

Can you provide your logic for the sheet selection?

i.e.

B3 = Y will select sheets 1.02, 1.04
B4 = Y will select sheets 1.03, 1.04
B5 = Y will select sheet...... etc etc

Could you have multiple Y's in the column? What would you expect to happen?

 

[exceljen86]

Hi Comfy,

It would be

B3 = Y will select 1.01, 1.03, 2.02
B4 = Y will select 1.02, 1.04, 2.01
B5 = Y will select 1.05, 1.06, 3.01
B6 = Y will select 1.03, 1.07, 2.01

(there will be about 15 of these in total)

Then the selected sheets would copy into a new workbook.

So for example if there was a Y next to B3 and B4 then sheets 1.01, 1.03, 2.02, 1.02, 1.04, 2.01 would all be copied into a new workbook.

Hope that makes a bit more sense

Thanks!

 

[Comfy]

Sorry for the lazy response but have a look at this.

Option Explicit
Sub CopySheets()


Dim rng As Range
Dim c As Range
Dim LookupLO As ListObject
Dim RefCol As Object
Dim ws As Worksheet
Dim wb1 As Workbook, Wb2 As Workbook
Dim ShtStr As String
Dim ShtArr As Variant
Dim i As Long


Set wb1 = ThisWorkbook
Set LookupLO = wb1.Sheets("Config").ListObjects("SheetsTbl")
Set rng = wb1.Sheets("Data").Range("B3:B6")
Set RefCol = CreateObject("Scripting.Dictionary")


For Each c In rng
    If LCase(c.Value) = "y" Then
        If Not RefCol.Exists(c.Address(False, False)) Then RefCol.Add c.Address(False, False), c.Address(False, False)
    End If
Next c


For i = 1 To LookupLO.DataBodyRange.Rows.Count
    If RefCol.Exists(CStr(LookupLO.ListColumns("Cell Ref").Range(i))) Then
    On Error GoTo 0
        Set ws = wb1.Sheets(LookupLO.ListColumns("Sheet Name").Range(i))
    On Error Resume Next
    If Not ws Is Nothing Then
        ShtStr = ShtStr & LookupLO.ListColumns("Sheet Name").Range(i) & ","
    End If
    Set ws = Nothing
    End If
Next i


ShtStr = Left(ShtStr, Len(ShtStr) - 1)
ShtArr = Split(ShtStr, ",")


Set Wb2 = Workbooks.Add
wb1.Sheets(ShtArr).Copy Before:=Wb2.Sheets(1)


End Sub

I have a worksheet called "Config"
In this sheet is a table called "SheetsTbl"
The table has two columns "Sheet Name" and "Cell Ref"
Each Sheet Name is listed along with the cell reference that will contain a "y"

 

[exceljen86]

Wow that's amazing! Thank you so much for your help!!!!!

 

[exceljen86]

Once again thank you so much for your help comfy!!!

I'm getting Runtime error 5 - Invalid procedure call or argument on

ShtStr = Left(ShtStr, Len(ShtStr) - 1)

 

[Comfy]

The string is probably empty (there are no sheets to copy)

Option Explicit
Sub CopySheets()




Dim rng As Range
Dim c As Range
Dim LookupLO As ListObject
Dim RefCol As Object
Dim ws As Worksheet
Dim wb1 As Workbook, Wb2 As Workbook
Dim ShtStr As String
Dim ShtArr As Variant
Dim i As Long




Set wb1 = ThisWorkbook
Set LookupLO = wb1.Sheets("Config").ListObjects("SheetsTbl")
Set rng = wb1.Sheets("Data").Range("B3:B6")
Set RefCol = CreateObject("Scripting.Dictionary")




For Each c In rng
    If LCase(c.Value) = "y" Then
        If Not RefCol.Exists(c.Address(False, False)) Then RefCol.Add c.Address(False, False), c.Address(False, False)
    End If
Next c




For i = 1 To LookupLO.DataBodyRange.Rows.Count
    If RefCol.Exists(CStr(LookupLO.ListColumns("Cell Ref").Range(i))) Then
    On Error GoTo 0
        Set ws = wb1.Sheets(LookupLO.ListColumns("Sheet Name").Range(i))
    On Error Resume Next
    If Not ws Is Nothing Then
        ShtStr = ShtStr & LookupLO.ListColumns("Sheet Name").Range(i) & ","
    End If
    Set ws = Nothing
    End If
Next i

If ShtStr <> "" Then


ShtStr = Left(ShtStr, Len(ShtStr) - 1)
ShtArr = Split(ShtStr, ",")




Set Wb2 = Workbooks.Add
wb1.Sheets(ShtArr).Copy Before:=Wb2.Sheets(1)
Else
MsgBox "No Sheets to Copy"
End if


End Sub

 

[exceljen86]

Aaah I've probably not put the cell references in correctly.

Thanks again!