Tuesday, March 8, 2016

Pulling set of rows and columns from a Excel Sheet and place that data under different multiple Sheets.





Public Filename, GCOT, FCCT, Status, Sheetname, Director1, Director

Sub Macro1()
Dim file1
MsgBox ("Open the GCOT automated report")
file1 = Application.GetOpenFilename()

Set owb = Application.Workbooks.Open(file1)

strString = Split(file1, "\")

 'UBound - Returns the highest available subscript for the indicated dimension of an array.
 For i = 0 To UBound(strString) - 1
     ' strNewPath = strNewPath & strString(i) & "\"
       
 Next

 Filename = strString(i)

MsgBox ("File name is: " & Filename)
Workbooks(Filename).Sheets(2).Activate

 GCOT = InputBox("Enter the column number for LOB_Tier1") 'getting values from user. Value for the field should be number
     FCCT = InputBox("Enter the column number for LOB_Tier2")
 Status = InputBox("Enter Idea_Status column number")
 Sheetname = ActiveWorkbook.Sheets(2).Name 'InputBox("Enter the main Sheet name")
 Director1 = InputBox("Enter 'Final Director Name' column number")


  For i = 2 To 12
 
  Workbooks(Filename).Sheets("Directorlist").Activate
   'throwing error unable to extract data from the directorlist
  Workbooks(Filename).Sheets("Directorlist").Cells(i, 3).Activate
  Director = ActiveCell.Value
 
  'Set Director = ActiveSheet.Cells(i, 0).Value
  Call directordata(Filename, Sheetname, Director)
  Next
 
  End Sub
 
Function directordata(Filename, Sheetname, Director)

  '//Sheila Wilson
    On Error Resume Next  'to check whether the Sheetname is matching with the name in the report
    Workbooks(Filename).Sheets(Sheetname).Activate
    If (Err.Number) Then
    MsgBox Sheename & " is not matching with name in the report"
    End If
    Workbooks(Filename).Sheets(Sheetname).Rows("5:5").Select
   
    If (Director <> "Jessica G Adams") Then
   
    Workbooks(Filename).Sheets(Sheetname).Range("$A$5:$W$5").AutoFilter Field:=GCOT, Criteria1:= _
        "GCOT"
       
    Workbooks(Filename).Sheets(Sheetname).Range("$A$5:$W$5").AutoFilter Field:=FCCT, Criteria1:= _
        "FCCT"
    End If
   
   
    Workbooks(Filename).Sheets(Sheetname).Range("$A$5:$W$5").AutoFilter Field:=Status, Criteria1:=Array("Approved", "Draft", "Future Pipeline", "In Progress", _
        "Pending Actuals", "Ready for Finance Review", "Submit for Approval"), Operator _
        :=xlFilterValues
        'Director
       
   
        Workbooks(Filename).Sheets(Sheetname).Range("$A$5:$W$5").AutoFilter Field:=Director1, Criteria1:=Director
     
         On Error Resume Next
         Workbooks(Filename).Sheets(Director).Activate
         If (Err.Number) Then
         MsgBox "Sheet name for " & Director & "does not match"
         End If
         Workbooks(Filename).Sheets(Director).Range("B25").Select
     
        Workbooks(Filename).Sheets(Director).Range(Selection, Selection.End(xlDown)).Select
        Workbooks(Filename).Sheets(Director).Range(Selection, Selection.End(xlToRight)).Select
         Selection.Clear
       
        Workbooks(Filename).Sheets(Sheetname).Activate
        Workbooks(Filename).Sheets(Sheetname).Range("A5").Select
       
        Workbooks(Filename).Sheets(Sheetname).Range(Selection, Selection.End(xlDown)).Select
        Workbooks(Filename).Sheets(Sheetname).Range(Selection, Selection.End(xlToRight)).Select
       
        Selection.Copy
       
     Workbooks(Filename).Sheets(Director).Activate
     Workbooks(Filename).Sheets(Director).Range("B25").Select
     
    Workbooks(Filename).Sheets(Director).Paste
   
    Workbooks(Filename).Sheets(Director).Range("B25").Select
    Workbooks(Filename).Sheets(Director).Range(Selection, Selection.End(xlDown)).Select
    Workbooks(Filename).Sheets(Director).Range(Selection, Selection.End(xlToRight)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.RowHeight = 15
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
   
     With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
       
    End With
   
   

        'Deleting unwanted  columns
       
    Workbooks(Filename).Sheets(Director).Range("B25").Select
    Workbooks(Filename).Sheets(Director).Range(Selection, Selection.End(xlDown)).Select
    Workbooks(Filename).Sheets(Director).Range(Selection, Selection.End(xlToRight)).Select
   
    Selection.Columns("G:I").Delete
    Selection.Columns("G:H").Delete
    Selection.Columns("L:Q").Delete
    Selection.Columns("N:AR").Delete
    Selection.Columns("O:AA").Delete 'Q 2015 saves deleted
    Selection.Columns("S:AK").Delete
    Selection.Columns("T:X").Delete
   
    ' Arranging the Automation type in descending order

    Workbooks(Filename).Sheets(Director).Range("N25").Select
   Rows2 = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
   
    Workbooks(Filename).Sheets(Director).Sort.SortFields.Clear ' will clear the existing sorting
    Workbooks(Filename).Sheets(Director).Sort.SortFields.Add Key:=Range("O25"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal  'xlAscending 'take a column and sort order
    With Workbooks(Filename).Sheets(Director).Sort  ' parameters of sorting include selecting table(Range), header, apply
       ' .SetRange Range("E15:G21")
        .SetRange Range("B26:T" & Rows2)
        .Header = xlGuess 'xlNo ' xlGuess or xlNo anyone could be used
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   Workbooks(Filename).Sheets(Sheetname).Activate
   
    Workbooks(Filename).Sheets(Sheetname).Range("$A$5:$W$5").AutoFilter
 
       
End Function


No comments:

Post a Comment