Solved: Dynamic array for Worksheets

[kathyb0527]

I have a spreadsheet with a tab for each client. I've modified code to consolidate basic information onto a "Main" tab (for use in mail merge later) using an array. What I would like to do is to be able to add or delete client tabs without having to edit the code each time. Here is the code I'm using:

Sub getmergedata()
'Original code copied from Mperrah VBA Express Forum
Dim sh_Source As Sheets
Dim sh_Dest As Worksheet, wks As Worksheet
Dim Cell As Range
Dim NextrowD As Variant
Set sh_Dest = Worksheets("Letters")
Set sh_Source = Worksheets(Array("04", "11", "23", "39", "65", "72", "93", "96", "110", "118", "125", "127", "128", "132", "146", "172", "175", "182", "184"))
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Call Deletedata
NextrowD = sh_Dest.Range("A" & Rows.Count).End(xlUp).Row
For Each wks In sh_Source
For Each Cell In wks.Range("A:A")
If Cell.Interior.ColorIndex = "39" And Cell.Value <> "" Then
NextrowD = NextrowD + 1
With wks
.Range("A" & Cell.Row).Copy
sh_Dest.Range("A" & NextrowD).PasteSpecial (xlPasteValues)
.Range("C" & Cell.Row).Copy
sh_Dest.Range("B" & NextrowD).PasteSpecial (xlPasteValues)
.Range("D" & Cell.Row).Copy
sh_Dest.Range("C" & NextrowD).PasteSpecial (xlPasteValues)
.Range("E" & Cell.Row).Copy
sh_Dest.Range("D" & NextrowD).PasteSpecial (xlPasteValues)
.Range("K" & Cell.Row).Copy
sh_Dest.Range("E" & NextrowD).PasteSpecial (xlPasteValues)
.Range("J" & Cell.Row).Copy
sh_Dest.Range("F" & NextrowD).PasteSpecial (xlPasteValues)
End With
End If
Next Cell
Next wks
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

I've attached a stripped down version of the spreadsheet.

Thanks for your help,
Kathyb0527:think:

[kathyb0527]

:omg2:Now it's posted twice. Sorry, internet interruptions!

[Bob Phillips]

Is this looking at all sheets exvept Letters?

[kathyb0527]

Yes, all but "Letters" although if it looks at "letters" it's not a problem.

[Bob Phillips]

You could just iterate throuh all sheets



Sub getmergedata()
'Original code copied from Mperrah VBA Express Forum
Dim sh_Dest As Worksheet, wks As Worksheet
Dim Cell As Range
Dim NextrowD As Variant

Set sh_Dest = Worksheets("Letters")
With Application

.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

Call Deletedata

NextrowD = sh_Dest.Range("A" & Rows.Count).End(xlUp).Row

For Each wks In ActiveWorkbook.Worksheets

If wks.nam <> "Letters" Then

For Each Cell In wks.Range("A:A")

If Cell.Interior.ColorIndex = "39" And Cell.Value <> "" Then

NextrowD = NextrowD + 1
With wks

.Range("A" & Cell.Row).Copy
sh_Dest.Range("A" & NextrowD).PasteSpecial (xlPasteValues)
.Range("C" & Cell.Row).Copy
sh_Dest.Range("B" & NextrowD).PasteSpecial (xlPasteValues)
.Range("D" & Cell.Row).Copy
sh_Dest.Range("C" & NextrowD).PasteSpecial (xlPasteValues)
.Range("E" & Cell.Row).Copy
sh_Dest.Range("D" & NextrowD).PasteSpecial (xlPasteValues)
.Range("K" & Cell.Row).Copy
sh_Dest.Range("E" & NextrowD).PasteSpecial (xlPasteValues)
.Range("J" & Cell.Row).Copy
sh_Dest.Range("F" & NextrowD).PasteSpecial (xlPasteValues)
End With
End If
Next Cell
End If
Next wks

With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

[kathyb0527]

Thanks XLD! I tried to do something like that originally, but I must have had something wrong because it didn't work. But this does!

Thanks again!