Loop to run a macro on few tabs only on the worksheet

[Heber]

Hi...<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
I have a macro that collect data from a spreadsheet and consolidated to another book.... but I have to do this to multiple tabs, but not all! How can I create a loop to look only on those specific tabs and extract the data? I have those tabs as number, actually are days of the month, start with 01 end with 31.... <o></o>
Thanks on advance!<o></o>

 

[Greg Truby]

A robust solution would to create named items that are scoped to the sheet for each sheet you wish to process. For example, add some named items to a couple of sheets using the name prpCustom and setting the RefersTo argument to something like =TRUE or anything really (even a range if you wish). Then loop and test for the existence of the property.

Sub ProcessOnlyCertainSheets()
    Const c_strPropName As String = "prpCustom"
    Dim namTest     As Excel.Name, _
        wbTarget    As Excel.Workbook, _
        wsItem      As Excel.Worksheet
 
    Set wbTarget = ActiveWorkbook
 
    For Each wsItem In wbTarget.Worksheets
        On Error Resume Next
        Set namTest = wsItem.Names(c_strPropName)
        On Error GoTo 0
        If Not namTest Is Nothing Then 
            '// code to execute for "matching" sheets
            MsgBox wsItem.Name, vbInformation
        End If
    Next wsItem
End Sub

 

[Heber]

thanks Greg for your feedback...
I am not expert on VBA, probabily I will ask a dumm question: where do I put the name: "prpCustom"? I can't replaced the tabs names.... I was think the macro could look the tabs between 01 and 31 and collect the data! cheers Heber

 

[Greg Truby]

It's a named constant. Same concept as a named range, same process as naming a range, but instead of pointing to a range when in the RefersTo edit box, just type in an equals sign and a constant value. If you do not know how to name ranges, then please indicate which version of Excel you use as the instructions are a little different for 2003 versus 2007/2010.

 

[Heber]

Hi Greg,
I use 2007 version, I know how to name a range, but I have 31 sheets that I have flick trought it, the macro collect 3 diferent ranges on each sheet, and paste on the workbook that is siting the macro, below is the code, maybe you can see what I need to do:

Sub data_creator()
'
' Data creator
Dim LR As Long
Dim LastCell As Long
Dim Lastrow As Long
Dim OpenA As Workbook, OpenB As Workbook
Dim NewFN As String
    
     
Set OpenA = ActiveWorkbook

NewFN = Application.GetOpenFilename(FileFilter:="Excel Files (*.xlsm), *.xlsm", Title:="Please select a file")
If NewFN = "False" Then
' They pressed Cancel
MsgBox "Stopping because you did not select a file"
Exit Sub
Else
End If
Workbooks.Open Filename:=NewFN
Set OpenB = Workbooks(Workbooks.Count)
OpenA.Activate
Sheets("data").Select
Lastrow = ActiveSheet.UsedRange.Rows.Count
Range(Cells(2, 1), Cells(Lastrow, 20)).Select
Selection.ClearContents

'01
'Part1
OpenB.Activate
        Sheets("01").Select
        Range("A1:S1").Select
        Selection.Copy
OpenA.Activate
        Sheets("data").Select
        ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        
OpenB.Activate
        Range("A3:R62").Select
        Application.CutCopyMode = False
        Selection.Copy
OpenA.Activate
        ActiveSheet.Range("C65536").End(xlUp).Offset(1, 0).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
            
      Range("E:E").SpecialCells(xlCellTypeBlanks).Select
        Selection.EntireRow.ClearContents
    
        Lastrow = ActiveSheet.UsedRange.Rows.Count
              
        LastCell = Range("A1:A65536").End(xlUp).Row
              
    ActiveSheet.Range("A65536").End(xlUp).Offset(0, 0).Select
    Selection.Copy
    
    LR = Range("C" & Rows.Count).End(xlUp).Row
    Range(Range("A" & Rows.Count).End(xlUp).Offset(0, 0), Range("A" & LR)) = Range("A65536").End(xlUp).Offset(0, 0)
    ActiveSheet.Paste
'Part2
OpenB.Activate
        Sheets("01").Select
        Range("A65:S65").Select
        Selection.Copy
OpenA.Activate
        Sheets("data").Select
        ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        
OpenB.Activate
        Range("A67:R126").Select
        Application.CutCopyMode = False
        Selection.Copy
OpenA.Activate
        ActiveSheet.Range("C65536").End(xlUp).Offset(1, 0).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
            
      Range("E:E").SpecialCells(xlCellTypeBlanks).Select
    Selection.EntireRow.ClearContents
    
    Lastrow = ActiveSheet.UsedRange.Rows.Count
    LastCell = Range("A1:A65536").End(xlUp).Row
              
    ActiveSheet.Range("A65536").End(xlUp).Offset(0, 0).Select
    Selection.Copy
    
    
    LR = Range("C" & Rows.Count).End(xlUp).Row
    Range(Range("A" & Rows.Count).End(xlUp).Offset(0, 0), Range("A" & LR)) = Range("A65536").End(xlUp).Offset(0, 0)
    
'Part3
OpenB.Activate
        Sheets("01").Select
        Range("A129:S129").Select
        Selection.Copy
OpenA.Activate
        Sheets("data").Select
        ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        
OpenB.Activate
        Range("A131:R190").Select
        Application.CutCopyMode = False
        Selection.Copy
OpenA.Activate
        ActiveSheet.Range("C65536").End(xlUp).Offset(1, 0).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
            
      Range("E:E").SpecialCells(xlCellTypeBlanks).Select
    Selection.EntireRow.ClearContents
    
    
    Lastrow = ActiveSheet.UsedRange.Rows.Count
    LastCell = Range("A1:A65536").End(xlUp).Row
              
    ActiveSheet.Range("A65536").End(xlUp).Offset(0, 0).Select
    Selection.Copy
    
    
    LR = Range("C" & Rows.Count).End(xlUp).Row
    Range(Range("A" & Rows.Count).End(xlUp).Offset(0, 0), Range("A" & LR)) = Range("A65536").End(xlUp).Offset(0, 0)

 

[Greg Truby]

Heber,

I'm not really looking at your code - I don't want to get sidetracked delving into that for the moment.

Just take a new, blank workbook and create some named constants like you see below.





Then use the F8 key to step through code I posted earlier and see what it's doing. You should see what I'm talking about.

The reason I'm showing you this approach is that trying to pick off worksheets based on the sheets' names is a solution of last resort because it's not robust in the slightest. If, for whatever reason, the naming protocol changes, your code fails. While one can indeed actually add true custom properties to worksheet objects, this solution is a little easier to maintain and a little more intuitive for VBA rookies. Furthermore, should you grow in your VBA skillz to a very high level, this solution still works for advanced architectures where you keep all code in an external AddIn and use codeless workbooks.

 

[Heber]

Thanks Greg.... I will follow up your instructions!! I have only few hours to finish this project; I will give the management the draft version, without the workings behind, and will start this from scratch!! Cheers!<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>