Using a Loop to perform operations

jakeman

jakeman

Active Member
Joined
Apr 29, 2008
Messages
325
Office Version
  1. 365
Platform
  1. Windows
Ok, here is what I am working on. Each week I have to put together a workbook with a sheet for each of the directors in my dept. This wasn't so bad before but we are adding new directors and departments lately, so the process has become more manual than before. I created a macro to do a lot of automating for me but it is proving to be more of a problem to update the VBA each time I have to add a new director. That said, it seems to me that the best option I have to make my life simple is to use a Loop statement in VBA, combined with a sheet that contains a list of the directors I need to create a sheet for. Right now my list contains 13 names. Here's what I'd like to do.

First, what I have to do is extract certain columns of information from the Master Data Repository (MDR) for each director. Then I create a new workbook and append the extracted columns of data by director to a specific sheet. For example, I go to the MDR and find the sheet for Joe Smith. I select columns B & C, F, then K-N. I copy the data and then open a new workbook and then paste the columns to the empty sheet and name that new sheet 'Smith'. Then I go back to the MDR and select the next director's sheet that I need, copy the columns, go back to the new workbook and create a sheet for the next director and paste the data to that sheet. So on and so forth.

The problem is that the MDR contains data for directors outside of my dept so I am only focused on the directors in my area. I have created a list of directors that I would need to pull data from the MDR for and create a new sheet for them. My thought is that I'd like to loop through the list of directors that I have and perform the steps that I mentioned before for each director in my list until I reach the end of the list. Since all of the names are there, I wouldn't need to manually enter anything in my code to find the people I need.

Here is some code I currently have that runs for a specific name that I put into my VBA...I have to create this same code for each new director I add and it is tedious...this is why I think I should be able to run this line of code again through a loop to do the steps I need:

Code: 
Dim SheetSmith as Integer

Workbooks.Open FileName:= MDR


'********* Extract Smith's Sheet</SPAN>
   
    Sheets("Smith").Select</SPAN>
   
    Set range1 = Sheets("Smith").Range("B1:C" & SheetSmith)</SPAN>
    Set range2 = Sheets("Smith").Range("F1:F" & SheetSmith)</SPAN>
    Set range3 = Sheets("Smith").Range("K1:N" & SheetSmith)</SPAN>
    Set multipleRange = Union(range1, range2, range3)</SPAN>
   
    multipleRange.Select</SPAN>
   
    Range("K1").Activate</SPAN>
    selection.Copy</SPAN>
   
    Workbooks.Add</SPAN>
   
    ActiveSheet.Paste</SPAN>
   
    Cells.Select</SPAN>
    With selection.Font</SPAN>
        .Name = "Calibri"</SPAN>
        .Size = 11</SPAN>
        .Strikethrough = False</SPAN>
        .Superscript = False</SPAN>
        .Subscript = False</SPAN>
        .OutlineFont = False</SPAN>
        .Shadow = False</SPAN>
        .Underline = xlUnderlineStyleNone</SPAN>
        .TintAndShade = 0</SPAN>
        .ThemeFont = xlThemeFontMinor</SPAN>
    End With</SPAN>
   
    selection.ColumnWidth = 68.57</SPAN>
    Cells.EntireRow.AutoFit</SPAN>
    Cells.EntireColumn.AutoFit</SPAN>
    ActiveWindow.Zoom = 85</SPAN>
   
    Rows("1:1").Select</SPAN>
    Rows("1:1").EntireRow.AutoFit</SPAN>
    selection.RowHeight = 33#</SPAN>
   
    Columns("A:A").Select</SPAN>
    Application.FindFormat.Clear</SPAN>
    selection.Replace What:="( ", Replacement:="(", LookAt:=xlPart, _</SPAN>
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _</SPAN>
        ReplaceFormat:=False</SPAN>
    selection.Replace What:="_*", Replacement:=")", LookAt:=xlPart, _</SPAN>
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _</SPAN>
        ReplaceFormat:=False</SPAN>
    selection.Replace What:="Smith (", Replacement:="", LookAt:=xlPart, _</SPAN>
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _</SPAN>
        ReplaceFormat:=False</SPAN>
    Columns("B:B").Select</SPAN>
    Application.CutCopyMode = False</SPAN>
    selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove</SPAN>
 
    Range("B2").Select</SPAN>
    ActiveCell.FormulaR1C1 = _</SPAN>
        "=IF(ISNUMBER(FIND("" ("",RC[-1])),RC[-1],LEFT(RC[-1],LEN(RC[-1])-1))"</SPAN>
    Range("B2").Select</SPAN>
    selection.AutoFill Destination:=Range("B2:B" & SheetSmith)</SPAN>
    Range("B2:B" & SheetSmith).Select</SPAN>
 
    selection.Copy</SPAN>
    Range("A2").Select</SPAN>
    selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _</SPAN>
        :=False, Transpose:=False</SPAN>
    Columns("B:B").Select</SPAN>
    Application.CutCopyMode = False</SPAN>
    selection.Delete Shift:=xlToLeft</SPAN>
   
    Range("G1:G" & SheetSmith).Select</SPAN>
    selection.Copy</SPAN>
    Range("H1").Select</SPAN>
    selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _</SPAN>
        SkipBlanks:=False, Transpose:=False</SPAN>
    Application.CutCopyMode = False</SPAN>
    Range("H1").Select</SPAN>
    ActiveCell.FormulaR1C1 = "Comment"</SPAN>
    Range("H2").Select</SPAN>
    Columns("H:H").EntireColumn.AutoFit</SPAN>
    Range("H1").Select</SPAN>
    With selection.Interior</SPAN>
        .Pattern = xlSolid</SPAN>
        .PatternColorIndex = xlAutomatic</SPAN>
        .ThemeColor = xlThemeColorAccent2</SPAN>
        .TintAndShade = -0.249977111117893</SPAN>
        .PatternTintAndShade = 0</SPAN>
    End With</SPAN>
   
    Range("C2:H" & SheetSmith).Select</SPAN>
    selection.Borders(xlDiagonalDown).LineStyle = xlNone</SPAN>
    selection.Borders(xlDiagonalUp).LineStyle = xlNone</SPAN>
    With selection.Borders(xlEdgeLeft)</SPAN>
        .LineStyle = xlContinuous</SPAN>
        .ColorIndex = 0</SPAN>
        .TintAndShade = 0</SPAN>
        .Weight = xlMedium</SPAN>
    End With</SPAN>
    With selection.Borders(xlEdgeTop)</SPAN>
        .LineStyle = xlContinuous</SPAN>
        .ColorIndex = 0</SPAN>
        .TintAndShade = 0</SPAN>
        .Weight = xlMedium</SPAN>
    End With</SPAN>
    With selection.Borders(xlEdgeBottom)</SPAN>
        .LineStyle = xlContinuous</SPAN>
        .ColorIndex = 0</SPAN>
        .TintAndShade = 0</SPAN>
        .Weight = xlMedium</SPAN>
    End With</SPAN>
    With selection.Borders(xlEdgeRight)</SPAN>
        .LineStyle = xlContinuous</SPAN>
        .ColorIndex = 0</SPAN>
        .TintAndShade = 0</SPAN>
        .Weight = xlMedium</SPAN>
    End With</SPAN>
    With selection.Borders(xlInsideVertical)</SPAN>
        .LineStyle = xlContinuous</SPAN>
        .ColorIndex = 0</SPAN>
        .TintAndShade = 0</SPAN>
        .Weight = xlThin</SPAN>
    End With</SPAN>
    With selection.Borders(xlInsideHorizontal)</SPAN>
        .LineStyle = xlContinuous</SPAN>
        .ColorIndex = 0</SPAN>
        .TintAndShade = 0</SPAN>
        .Weight = xlThin</SPAN>
    End With</SPAN>
   
   
    '*************** Sort Descending YTD Score</SPAN>
       
    Range("A1").Select</SPAN>
    selection.AutoFilter</SPAN>
    Range("G2").Select</SPAN>
    ActiveSheet.AutoFilter.Sort.SortFields.Clear</SPAN>
    ActiveSheet.AutoFilter.Sort.SortFields.Add Key:= _</SPAN>
        Range("G2"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _</SPAN>
        xlSortNormal</SPAN>
    With ActiveSheet.AutoFilter.Sort</SPAN>
        .Header = xlYes</SPAN>
        .MatchCase = False</SPAN>
        .Orientation = xlTopToBottom</SPAN>
        .SortMethod = xlPinYin</SPAN>
        .Apply</SPAN>
    End With</SPAN>
   
    ActiveWindow.DisplayGridlines = False</SPAN>
   
    Columns("A:H").EntireColumn.AutoFit</SPAN>
   
   
    '********** Add Totals Row</SPAN>
   
    Range(Cells(SheetSmith + 1, 2), Cells(SheetSmith + 1, 4)).Select</SPAN>
   
    With selection.Interior</SPAN>
        .Pattern = xlSolid</SPAN>
        .PatternColorIndex = xlAutomatic</SPAN>
        .ThemeColor = xlThemeColorAccent1</SPAN>
        .Color = 16764057</SPAN>
        .TintAndShade = 0</SPAN>
        .PatternTintAndShade = 0</SPAN>
    End With</SPAN>
   
    Range("B" & SheetSmith + 1).Select</SPAN>
    With selection</SPAN>
        .HorizontalAlignment = xlLeft</SPAN>
    End With</SPAN>
   
    Range("B" & SheetSmith + 1).FormulaR1C1 = "Current Score based upon MBO currently reported"</SPAN>
    Range("C" & SheetSmith + 1).Formula = "=SUM(R2C:R[-1]C)"</SPAN>
    Range("D" & SheetSmith + 1).Formula = "=SUM(R2C:R[-1]C)"</SPAN>
   
    Range(Cells(SheetSmith + 1, 2), Cells(SheetSmith + 1, 4)).Select</SPAN>
   
    With selection.Font</SPAN>
        .Name = "Calibri"</SPAN>
        .FontStyle = "Regular"</SPAN>
        .Size = 14</SPAN>
        .Strikethrough = False</SPAN>
        .Superscript = False</SPAN>
        .Subscript = False</SPAN>
        .OutlineFont = False</SPAN>
        .Shadow = False</SPAN>
        .Underline = xlUnderlineStyleNone</SPAN>
        .ColorIndex = xlAutomatic</SPAN>
        .TintAndShade = 0</SPAN>
        .ThemeFont = xlThemeFontMinor</SPAN>
    End With</SPAN>
    selection.Borders(xlDiagonalDown).LineStyle = xlNone</SPAN>
    selection.Borders(xlDiagonalUp).LineStyle = xlNone</SPAN>
    With selection.Borders(xlEdgeLeft)</SPAN>
        .LineStyle = xlContinuous</SPAN>
        .ColorIndex = 0</SPAN>
        .TintAndShade = 0</SPAN>
        .Weight = xlMedium</SPAN>
    End With</SPAN>
    With selection.Borders(xlEdgeTop)</SPAN>
        .LineStyle = xlContinuous</SPAN>
        .ColorIndex = 0</SPAN>
        .TintAndShade = 0</SPAN>
        .Weight = xlMedium</SPAN>
    End With</SPAN>
    With selection.Borders(xlEdgeBottom)</SPAN>
        .LineStyle = xlContinuous</SPAN>
        .ColorIndex = 0</SPAN>
        .TintAndShade = 0</SPAN>
        .Weight = xlMedium</SPAN>
    End With</SPAN>
    With selection.Borders(xlEdgeRight)</SPAN>
        .LineStyle = xlContinuous</SPAN>
        .ColorIndex = 0</SPAN>
        .TintAndShade = 0</SPAN>
        .Weight = xlMedium</SPAN>
    End With</SPAN>
    With selection.Borders(xlInsideVertical)</SPAN>
        .LineStyle = xlContinuous</SPAN>
        .ColorIndex = 0</SPAN>
        .TintAndShade = 0</SPAN>
        .Weight = xlMedium</SPAN>
    End With</SPAN>
    selection.Borders(xlInsideHorizontal).LineStyle = xlNone</SPAN>
    selection.Font.Bold = True</SPAN>
   
   
    '********* Align text to the right</SPAN>
   
    Range("C2:H" & SheetSmith + 1).Select</SPAN>
   
    With selection</SPAN>
        .HorizontalAlignment = xlRight</SPAN>
        .VerticalAlignment = xlBottom</SPAN>
        .WrapText = False</SPAN>
        .Orientation = 0</SPAN>
        .AddIndent = False</SPAN>
        .IndentLevel = 0</SPAN>
        .ShrinkToFit = False</SPAN>
        .ReadingOrder = xlContext</SPAN>
        .MergeCells = False</SPAN>
    End With</SPAN>
 
    Range("A1").Select</SPAN>
    ActiveSheet.Name = "Smith"</SPAN>


REPEAT STEPS but refer to the List of Directors and next available Director Name
 

Excel Facts

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)
Sort by date Sort by votes
Hi,

I haven't added all the code but here is what I think you need for the loop.
It creates an array of director names from Column A in Sheet1. (Modify to suit). You can therefore add/remove names as and when.
It checks the Worksheet of the director name exists or jumps to the next if not.

You can try it as is on a copy and get it to cycle through the worksheets successfully before adding your code.
I hope it sets you in the right direction.

Code: 
Sub DirectorList()
Dim DirectList()

'Create Array of Directors to last filled cell
    Set Ws = Sheets("Sheet1")
    DirectList = WorksheetFunction.Transpose(Range(Ws.Range("A1"), Ws.Range("A" & Rows.Count).End(xlUp)))

    For x = LBound(DirectList) To UBound(DirectList)
            MsgBox DirectList(x)
            
   If WorksheetExists(DirectList(x)) Then
   
   DirectorNme = DirectList(x)
            
   Sheets(DirectorNme).Select

     
   'Do your thing....
   
               
    End If
    Next
    
    
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Solved
formating question
Replies
3
Views
172
Micron
M
L
  • Locked
  • Question
Help Cleaning Up Code
Replies
2
Views
436
RoryA
RoryA
P
  • Question
Issue with button not running in spread sheet only in test mode
Replies
1
Views
264
6StringJazzer
6StringJazzer
K
  • Solved
create a button that do actions
2 3
Replies
22
Views
1K
kerm007
K
E
  • Solved
Auto open vba select column
Replies
8
Views
172
JerrExcel
JerrExcel

Forum statistics

Threads
1,217,361
Messages
6,136,104
Members
449,992
Latest member
amadams

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top